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 --                            $Revision: 1.1 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Exceptions;
  37 with Ada.Tags;
  38 with Ada.Unchecked_Conversion;
  39 with System.Storage_Elements;
  40 with System.Soft_Links;
  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    package SSE renames System.Storage_Elements;
  50    use type SSE.Storage_Offset;
  51
  52    -----------------------
  53    -- Local Subprograms --
  54    -----------------------
  55
  56    function To_Finalizable_Ptr is
  57      new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);
  58
  59    function To_Addr is
  60      new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);
  61
  62    type RC_Ptr is access all Record_Controller;
  63
  64    function To_RC_Ptr is
  65      new Ada.Unchecked_Conversion (Address, RC_Ptr);
  66
  67    procedure Raise_Exception_No_Defer
  68      (E       : in Exception_Id;
  69       Message : in String := "");
  70    pragma Import (Ada, Raise_Exception_No_Defer,
  71      "ada__exceptions__raise_exception_no_defer");
  72    pragma No_Return (Raise_Exception_No_Defer);
  73    --  Raise an exception without deferring abort. Note that we have to
  74    --  use this rather kludgy Ada Import interface, since this subprogram
  75    --  is not available in the visible spec of Ada.Exceptions.
  76
  77    procedure Raise_From_Finalize
  78      (L          : Finalizable_Ptr;
  79       From_Abort : Boolean;
  80       E_Occ      : Exception_Occurrence);
  81    --  Deal with an exception raised during finalization of a list. L is a
  82    --  pointer to the list of element not yet finalized. From_Abort is true
  83    --  if the finalization actions come from an abort rather than a normal
  84    --  exit. E_Occ represents the exception being raised.
  85
  86    function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset;
  87    pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset");
  88
  89    function Parent_Size (Obj : Address) return SSE.Storage_Count;
  90    pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
  91
  92    function Get_RC_Dynamically (Obj : Address) return Address;
  93    --  Given an the address of an object (obj) of a tagged extension with
  94    --  controlled component, computes the address of the record controller
  95    --  located just after the _parent field
  96
  97    -------------
  98    --  Adjust --
  99    -------------
 100
 101    procedure Adjust (Object : in out Record_Controller) is
 102
 103       First_Comp : Finalizable_Ptr;
 104       My_Offset : constant SSE.Storage_Offset :=
 105                     Object.My_Address - Object'Address;
 106
 107       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
 108       --  Subtract the offset to the pointer
 109
 110       procedure Reverse_Adjust (P : Finalizable_Ptr);
 111       --  Adjust the components in the reverse order in which they are stored
 112       --  on the finalization list. (Adjust and Finalization are not done in
 113       --  the same order)
 114
 115       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
 116       begin
 117          if Ptr /= null then
 118             Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset);
 119          end if;
 120       end Ptr_Adjust;
 121
 122       procedure Reverse_Adjust (P : Finalizable_Ptr) is
 123       begin
 124          if P /= null then
 125             Ptr_Adjust (P.Next);
 126             Reverse_Adjust (P.Next);
 127             Adjust (P.all);
 128             Object.F := P;   --  Successfully adjusted, so place in list.
 129          end if;
 130       end Reverse_Adjust;
 131
 132    --  Start of processing for Adjust
 133
 134    begin
 135       --  Adjust the components and their finalization pointers next.
 136       --  We must protect against an exception in some call to Adjust, so
 137       --  we keep pointing to the list of successfully adjusted components,
 138       --  which can be finalized if an exception is raised.
 139
 140       First_Comp := Object.F;
 141       Object.F := null;               --  nothing adjusted yet.
 142       Ptr_Adjust (First_Comp);        --  set addresss of first component.
 143       Reverse_Adjust (First_Comp);
 144
 145       --  Then Adjust the controller itself
 146
 147       Object.My_Address := Object'Address;
 148
 149    exception
 150       when others =>
 151          --  Finalize those components that were successfully adjusted, and
 152          --  propagate exception. The object itself is not yet attached to
 153          --  global finalization list, so we cannot rely on the outer call
 154          --  to Clean to take care of these components.
 155
 156          Finalize (Object);
 157          raise;
 158    end Adjust;
 159
 160    --------------------------
 161    -- Attach_To_Final_List --
 162    --------------------------
 163
 164    procedure Attach_To_Final_List
 165      (L       : in out Finalizable_Ptr;
 166       Obj     : in out Finalizable;
 167       Nb_Link : Short_Short_Integer)
 168    is
 169    begin
 170       --  Simple case: attachement to a one way list
 171
 172       if Nb_Link = 1 then
 173          Obj.Next := L;
 174          L        := Obj'Unchecked_Access;
 175
 176       --  Dynamically allocated objects: they are attached to a doubly
 177       --  linked list, so that an element can be finalized at any moment
 178       --  by means of an unchecked deallocation. Attachement is
 179       --  protected against multi-threaded access.
 180
 181       elsif Nb_Link = 2 then
 182
 183          Locked_Processing : begin
 184             SSL.Lock_Task.all;
 185             Obj.Next    := L.Next;
 186             Obj.Prev    := L.Next.Prev;
 187             L.Next.Prev := Obj'Unchecked_Access;
 188             L.Next      := Obj'Unchecked_Access;
 189             SSL.Unlock_Task.all;
 190
 191          exception
 192             when others =>
 193                SSL.Unlock_Task.all;
 194                raise;
 195          end Locked_Processing;
 196
 197       --  Attachement of arrays to the final list (used only for objects
 198       --  returned by function). Obj, in this case is the last element,
 199       --  but all other elements are already threaded after it. We just
 200       --  attach the rest of the final list at the end of the array list.
 201
 202       elsif Nb_Link = 3 then
 203          declare
 204             P : Finalizable_Ptr := Obj'Unchecked_Access;
 205
 206          begin
 207             while P.Next /= null loop
 208                P := P.Next;
 209             end loop;
 210
 211             P.Next := L;
 212             L := Obj'Unchecked_Access;
 213          end;
 214       end if;
 215
 216    end Attach_To_Final_List;
 217
 218    ---------------------
 219    -- Deep_Tag_Adjust --
 220    ---------------------
 221
 222    procedure Deep_Tag_Adjust
 223      (L : in out SFR.Finalizable_Ptr;
 224       A : System.Address;
 225       B : Short_Short_Integer)
 226    is
 227       V      : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
 228       Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
 229
 230       Controller : RC_Ptr;
 231
 232    begin
 233       --  Has controlled components
 234
 235       if Offset /= 0 then
 236          if Offset > 0 then
 237             Controller := To_RC_Ptr (A + Offset);
 238          else
 239             Controller := To_RC_Ptr (Get_RC_Dynamically (A));
 240          end if;
 241
 242          Adjust (Controller.all);
 243          Attach_To_Final_List (L, Controller.all, B);
 244
 245       --  Is controlled
 246
 247       elsif V.all in Finalizable then
 248          Adjust (V.all);
 249          Attach_To_Final_List (L, Finalizable (V.all), 1);
 250       end if;
 251    end Deep_Tag_Adjust;
 252
 253    ---------------------
 254    -- Deep_Tag_Attach --
 255    ----------------------
 256
 257    procedure Deep_Tag_Attach
 258      (L : in out SFR.Finalizable_Ptr;
 259       A : System.Address;
 260       B : Short_Short_Integer)
 261    is
 262       V      : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
 263       Offset : constant SSE.Storage_Offset  := RC_Offset (V'Tag);
 264
 265       Controller : RC_Ptr;
 266
 267    begin
 268       if Offset /= 0 then
 269          if Offset > 0 then
 270             Controller := To_RC_Ptr (A + Offset);
 271          else
 272             Controller := To_RC_Ptr (Get_RC_Dynamically (A));
 273          end if;
 274
 275          Attach_To_Final_List (L, Controller.all, B);
 276
 277       --  Is controlled
 278
 279       elsif V.all in Finalizable then
 280          Attach_To_Final_List (L, V.all, B);
 281       end if;
 282    end Deep_Tag_Attach;
 283
 284    -----------------------
 285    -- Deep_Tag_Finalize --
 286    -----------------------
 287
 288    procedure Deep_Tag_Finalize
 289      (L : in out SFR.Finalizable_Ptr;
 290       A : System.Address;
 291       B : Boolean)
 292    is
 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    begin
 519       null;
 520    end Initialize;
 521
 522    procedure Initialize (Object : in out Record_Controller) is
 523    begin
 524       Object.My_Address := Object'Address;
 525    end Initialize;
 526
 527    -------------------------
 528    -- Raise_From_Finalize --
 529    -------------------------
 530
 531    procedure Raise_From_Finalize
 532      (L          : Finalizable_Ptr;
 533       From_Abort : Boolean;
 534       E_Occ      : Exception_Occurrence)
 535    is
 536       Msg : constant String := Exception_Message (E_Occ);
 537       P   : Finalizable_Ptr := L;
 538       Q   : Finalizable_Ptr;
 539
 540    begin
 541       --  We already got an exception. We now finalize the remainder of
 542       --  the list, ignoring all further exceptions.
 543
 544       while P /= null loop
 545          Q := P.Next;
 546
 547          begin
 548             Finalize (P.all);
 549          exception
 550             when others => null;
 551          end;
 552
 553          P := Q;
 554       end loop;
 555
 556       --  If finalization from an Abort, then nothing to do
 557
 558       if From_Abort then
 559          null;
 560
 561       --  If no message, then add our own message saying what happened
 562
 563       elsif Msg = "" then
 564          Raise_Exception_No_Defer
 565            (E       => Program_Error'Identity,
 566             Message => "exception " &
 567                        Exception_Name (E_Occ) &
 568                        " raised during finalization");
 569
 570       --  If there was a message, pass it on
 571
 572       else
 573          Raise_Exception_No_Defer (Program_Error'Identity, Msg);
 574       end if;
 575    end Raise_From_Finalize;
 576
 577 --  Initialization of package, set Adafinal soft link
 578
 579 begin
 580    SSL.Adafinal := Finalize_Global_List'Access;
 581
 582 end System.Finalization_Implementation;