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