gcc/ada/s-tataat.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --         S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S      --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --                             $Revision: 1.14 $
  10 --                                                                          --
  11 --             Copyright (C) 1995-1999 Florida State University             --
  12 --                                                                          --
  13 -- GNARL 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. GNARL 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 GNARL; 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 -- GNARL was developed by the GNARL team at Florida State University. It is --
  32 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  33 -- State University (http://www.gnat.com).                                  --
  34 --                                                                          --
  35 ------------------------------------------------------------------------------
  36
  37 with System.Storage_Elements;
  38 --  used for To_Address
  39
  40 with System.Task_Primitives.Operations;
  41 --  used for Write_Lock
  42 --           Unlock
  43 --           Lock/Unlock_All_Tasks_List
  44
  45 with System.Tasking.Initialization;
  46 --  used for Defer_Abort
  47 --           Undefer_Abort
  48
  49 with Unchecked_Conversion;
  50
  51 package body System.Tasking.Task_Attributes is
  52
  53    use Task_Primitives.Operations,
  54        System.Tasking.Initialization;
  55
  56    function To_Access_Node is new Unchecked_Conversion
  57      (Access_Address, Access_Node);
  58    --  Tetch pointer to indirect attribute list
  59
  60    function To_Access_Address is new Unchecked_Conversion
  61      (Access_Node, Access_Address);
  62    --  Store pointer to indirect attribute list
  63
  64    --------------
  65    -- Finalize --
  66    --------------
  67
  68    procedure Finalize (X : in out Instance) is
  69       Q, To_Be_Freed : Access_Node;
  70
  71    begin
  72       Defer_Abortion;
  73       Write_Lock (All_Attrs_L'Access);
  74
  75       --  Remove this instantiation from the list of all instantiations.
  76
  77       declare
  78          P : Access_Instance;
  79          Q : Access_Instance := All_Attributes;
  80
  81       begin
  82          while Q /= null and then Q /= X'Unchecked_Access loop
  83             P := Q; Q := Q.Next;
  84          end loop;
  85
  86          pragma Assert (Q /= null);
  87
  88          if P = null then
  89             All_Attributes := Q.Next;
  90          else
  91             P.Next := Q.Next;
  92          end if;
  93       end;
  94
  95       if X.Index /= 0 then
  96
  97          --  Free location of this attribute, for reuse.
  98
  99          In_Use := In_Use and not (2**Natural (X.Index));
 100
 101          --  There is no need for finalization in this case,
 102          --  since controlled types are too big to fit in the TCB.
 103
 104       else
 105          --  Remove nodes for this attribute from the lists of
 106          --  all tasks, and deallocate the nodes.
 107          --  Deallocation does finalization, if necessary.
 108
 109          Lock_All_Tasks_List;
 110
 111          declare
 112             C : System.Tasking.Task_ID := All_Tasks_List;
 113             P : Access_Node;
 114
 115          begin
 116             while C /= null loop
 117                Write_Lock (C);
 118
 119                Q := To_Access_Node (C.Indirect_Attributes);
 120                while Q /= null
 121                  and then Q.Instance /= X'Unchecked_Access
 122                loop
 123                   P := Q;
 124                   Q := Q.Next;
 125                end loop;
 126
 127                if Q /= null then
 128                   if P = null then
 129                      C.Indirect_Attributes := To_Access_Address (Q.Next);
 130                   else
 131                      P.Next := Q.Next;
 132                   end if;
 133
 134                   --  Can't Deallocate now since we are holding the All_Tasks_L
 135                   --  lock.
 136
 137                   Q.Next := To_Be_Freed;
 138                   To_Be_Freed := Q;
 139                end if;
 140
 141                Unlock (C);
 142                C := C.Common.All_Tasks_Link;
 143             end loop;
 144          end;
 145
 146          Unlock_All_Tasks_List;
 147       end if;
 148
 149       Unlock (All_Attrs_L'Access);
 150
 151       while To_Be_Freed /= null loop
 152          Q := To_Be_Freed;
 153          To_Be_Freed := To_Be_Freed.Next;
 154          X.Deallocate.all (Q);
 155       end loop;
 156
 157       Undefer_Abortion;
 158
 159    exception
 160       when others => null;
 161          pragma Assert (False,
 162            "Exception in task attribute instance finalization");
 163    end Finalize;
 164
 165    -------------------------
 166    -- Finalize Attributes --
 167    -------------------------
 168
 169    --  This is to be called just before the ATCB is deallocated.
 170    --  It relies on the caller holding T.L write-lock on entry.
 171
 172    procedure Finalize_Attributes (T : Task_ID) is
 173       P : Access_Node;
 174       Q : Access_Node := To_Access_Node (T.Indirect_Attributes);
 175
 176    begin
 177       --  Deallocate all the indirect attributes of this task.
 178
 179       while Q /= null loop
 180          P := Q;
 181          Q := Q.Next; P.Instance.Deallocate.all (P);
 182       end loop;
 183
 184       T.Indirect_Attributes := null;
 185
 186    exception
 187       when others => null;
 188          pragma Assert (False,
 189            "Exception in per-task attributes finalization");
 190    end Finalize_Attributes;
 191
 192    ---------------------------
 193    -- Initialize Attributes --
 194    ---------------------------
 195
 196    --  This is to be called by System.Task_Stages.Create_Task.
 197    --  It relies on their being no concurrent access to this TCB,
 198    --  so it does not defer abortion or lock T.L.
 199
 200    procedure Initialize_Attributes (T : Task_ID) is
 201       P : Access_Instance;
 202
 203    begin
 204       Write_Lock (All_Attrs_L'Access);
 205
 206       --  Initialize all the direct-access attributes of this task.
 207
 208       P := All_Attributes;
 209       while P /= null loop
 210          if P.Index /= 0 then
 211             T.Direct_Attributes (P.Index) :=
 212               System.Storage_Elements.To_Address (P.Initial_Value);
 213          end if;
 214
 215          P := P.Next;
 216       end loop;
 217
 218       Unlock (All_Attrs_L'Access);
 219
 220    exception
 221       when others => null;
 222          pragma Assert (False);
 223    end Initialize_Attributes;
 224
 225 end System.Tasking.Task_Attributes;