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