1------------------------------------------------------------------------------ 2-- -- 3-- GNAT 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-- Copyright (C) 1991-1994, Florida State University -- 10-- Copyright (C) 1995-2013, AdaCore -- 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 3, 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. -- 18-- -- 19-- As a special exception under Section 7 of GPL version 3, you are granted -- 20-- additional permissions described in the GCC Runtime Library Exception, -- 21-- version 3.1, as published by the Free Software Foundation. -- 22-- -- 23-- You should have received a copy of the GNU General Public License and -- 24-- a copy of the GCC Runtime Library Exception along with this program; -- 25-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26-- <http://www.gnu.org/licenses/>. -- 27-- -- 28-- GNARL was developed by the GNARL team at Florida State University. -- 29-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 30-- -- 31------------------------------------------------------------------------------ 32 33with Ada.Unchecked_Conversion; 34 35with System.Task_Primitives.Operations; 36with System.Tasking.Initialization; 37 38package body System.Tasking.Task_Attributes is 39 40 use Task_Primitives.Operations; 41 use Tasking.Initialization; 42 43 function To_Access_Address is new Ada.Unchecked_Conversion 44 (Access_Node, Access_Address); 45 -- Store pointer to indirect attribute list 46 47 -------------- 48 -- Finalize -- 49 -------------- 50 51 procedure Finalize (X : in out Instance) is 52 Q, To_Be_Freed : Access_Node; 53 Self_Id : constant Task_Id := Self; 54 55 begin 56 -- Defer abort. Note that we use the nestable versions of Defer_Abort 57 -- and Undefer_Abort, because abort can already deferred when this is 58 -- called during finalization, which would cause an assert failure 59 -- in Defer_Abort. 60 61 Defer_Abort_Nestable (Self_Id); 62 Lock_RTS; 63 64 -- Remove this instantiation from the list of all instantiations 65 66 declare 67 P : Access_Instance; 68 Q : Access_Instance := All_Attributes; 69 70 begin 71 while Q /= null and then Q /= X'Unchecked_Access loop 72 P := Q; Q := Q.Next; 73 end loop; 74 75 pragma Assert (Q /= null); 76 77 if P = null then 78 All_Attributes := Q.Next; 79 else 80 P.Next := Q.Next; 81 end if; 82 end; 83 84 if X.Index /= 0 then 85 86 -- Free location of this attribute, for reuse 87 88 In_Use := In_Use and not (2**Natural (X.Index)); 89 90 -- There is no need for finalization in this case, since controlled 91 -- types are too big to fit in the TCB. 92 93 else 94 -- Remove nodes for this attribute from the lists of all tasks, 95 -- and deallocate the nodes. Deallocation does finalization, if 96 -- necessary. 97 98 declare 99 C : System.Tasking.Task_Id := All_Tasks_List; 100 P : Access_Node; 101 102 begin 103 while C /= null loop 104 Write_Lock (C); 105 106 Q := To_Access_Node (C.Indirect_Attributes); 107 while Q /= null 108 and then Q.Instance /= X'Unchecked_Access 109 loop 110 P := Q; 111 Q := Q.Next; 112 end loop; 113 114 if Q /= null then 115 if P = null then 116 C.Indirect_Attributes := To_Access_Address (Q.Next); 117 else 118 P.Next := Q.Next; 119 end if; 120 121 -- Can't Deallocate now since we are holding RTS_Lock 122 123 Q.Next := To_Be_Freed; 124 To_Be_Freed := Q; 125 end if; 126 127 Unlock (C); 128 C := C.Common.All_Tasks_Link; 129 end loop; 130 end; 131 end if; 132 133 Unlock_RTS; 134 135 while To_Be_Freed /= null loop 136 Q := To_Be_Freed; 137 To_Be_Freed := To_Be_Freed.Next; 138 X.Deallocate.all (Q); 139 end loop; 140 141 Undefer_Abort_Nestable (Self_Id); 142 143 exception 144 when others => 145 null; 146 pragma Assert (False, 147 "Exception in task attribute instance finalization"); 148 end Finalize; 149 150 ------------------------- 151 -- Finalize Attributes -- 152 ------------------------- 153 154 -- This is to be called just before the ATCB is deallocated. 155 -- It relies on the caller holding T.L write-lock on entry. 156 157 procedure Finalize_Attributes (T : Task_Id) is 158 P : Access_Node; 159 Q : Access_Node := To_Access_Node (T.Indirect_Attributes); 160 161 begin 162 -- Deallocate all the indirect attributes of this task 163 164 while Q /= null loop 165 P := Q; 166 Q := Q.Next; P.Instance.Deallocate.all (P); 167 end loop; 168 169 T.Indirect_Attributes := null; 170 171 exception 172 when others => 173 null; 174 pragma Assert (False, 175 "Exception in per-task attributes finalization"); 176 end Finalize_Attributes; 177 178 --------------------------- 179 -- Initialize Attributes -- 180 --------------------------- 181 182 -- This is to be called by System.Tasking.Stages.Create_Task 183 184 procedure Initialize_Attributes (T : Task_Id) is 185 P : Access_Instance; 186 Self_Id : constant Task_Id := Self; 187 188 begin 189 -- Note: we call [Un]Defer_Abort_Nestable, rather than [Un]Defer_Abort, 190 -- because Abort might already be deferred in Create_Task. 191 192 Defer_Abort_Nestable (Self_Id); 193 Lock_RTS; 194 195 -- Initialize all the direct-access attributes of this task 196 197 P := All_Attributes; 198 199 while P /= null loop 200 if P.Index /= 0 then 201 T.Direct_Attributes (P.Index) := 202 Direct_Attribute_Element 203 (System.Storage_Elements.To_Address (P.Initial_Value)); 204 end if; 205 206 P := P.Next; 207 end loop; 208 209 Unlock_RTS; 210 Undefer_Abort_Nestable (Self_Id); 211 212 exception 213 when others => 214 null; 215 pragma Assert (False); 216 end Initialize_Attributes; 217 218end System.Tasking.Task_Attributes; 219