1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1991-1994, Florida State University -- 10-- Copyright (C) 1995-2014, 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 33pragma Polling (Off); 34-- Turn off polling, we do not want ATC polling to take place during tasking 35-- operations. It causes infinite loops and other problems. 36 37with System.Task_Primitives.Operations; 38with System.Parameters; 39with System.Traces; 40with System.Soft_Links.Tasking; 41 42with System.Secondary_Stack; 43pragma Elaborate_All (System.Secondary_Stack); 44pragma Unreferenced (System.Secondary_Stack); 45-- Make sure the body of Secondary_Stack is elaborated before calling 46-- Init_Tasking_Soft_Links. See comments for this routine for explanation. 47 48package body System.Tasking.Protected_Objects is 49 50 use System.Task_Primitives.Operations; 51 use System.Traces; 52 53 ---------------- 54 -- Local Data -- 55 ---------------- 56 57 Locking_Policy : Character; 58 pragma Import (C, Locking_Policy, "__gl_locking_policy"); 59 60 ------------------------- 61 -- Finalize_Protection -- 62 ------------------------- 63 64 procedure Finalize_Protection (Object : in out Protection) is 65 begin 66 Finalize_Lock (Object.L'Unrestricted_Access); 67 end Finalize_Protection; 68 69 --------------------------- 70 -- Initialize_Protection -- 71 --------------------------- 72 73 procedure Initialize_Protection 74 (Object : Protection_Access; 75 Ceiling_Priority : Integer) 76 is 77 Init_Priority : Integer := Ceiling_Priority; 78 79 begin 80 if Init_Priority = Unspecified_Priority then 81 Init_Priority := System.Priority'Last; 82 end if; 83 84 Initialize_Lock (Init_Priority, Object.L'Access); 85 Object.Ceiling := System.Any_Priority (Init_Priority); 86 Object.New_Ceiling := System.Any_Priority (Init_Priority); 87 Object.Owner := Null_Task; 88 end Initialize_Protection; 89 90 ----------------- 91 -- Get_Ceiling -- 92 ----------------- 93 94 function Get_Ceiling 95 (Object : Protection_Access) return System.Any_Priority is 96 begin 97 return Object.New_Ceiling; 98 end Get_Ceiling; 99 100 ---------- 101 -- Lock -- 102 ---------- 103 104 procedure Lock (Object : Protection_Access) is 105 Ceiling_Violation : Boolean; 106 107 begin 108 -- The lock is made without deferring abort 109 110 -- Therefore the abort has to be deferred before calling this routine. 111 -- This means that the compiler has to generate a Defer_Abort call 112 -- before the call to Lock. 113 114 -- The caller is responsible for undeferring abort, and compiler 115 -- generated calls must be protected with cleanup handlers to ensure 116 -- that abort is undeferred in all cases. 117 118 -- If pragma Detect_Blocking is active then, as described in the ARM 119 -- 9.5.1, par. 15, we must check whether this is an external call on a 120 -- protected subprogram with the same target object as that of the 121 -- protected action that is currently in progress (i.e., if the caller 122 -- is already the protected object's owner). If this is the case hence 123 -- Program_Error must be raised. 124 125 if Detect_Blocking and then Object.Owner = Self then 126 raise Program_Error; 127 end if; 128 129 Write_Lock (Object.L'Access, Ceiling_Violation); 130 131 if Parameters.Runtime_Traces then 132 Send_Trace_Info (PO_Lock); 133 end if; 134 135 if Ceiling_Violation then 136 raise Program_Error; 137 end if; 138 139 -- We are entering in a protected action, so that we increase the 140 -- protected object nesting level (if pragma Detect_Blocking is 141 -- active), and update the protected object's owner. 142 143 if Detect_Blocking then 144 declare 145 Self_Id : constant Task_Id := Self; 146 begin 147 -- Update the protected object's owner 148 149 Object.Owner := Self_Id; 150 151 -- Increase protected object nesting level 152 153 Self_Id.Common.Protected_Action_Nesting := 154 Self_Id.Common.Protected_Action_Nesting + 1; 155 end; 156 end if; 157 end Lock; 158 159 -------------------- 160 -- Lock_Read_Only -- 161 -------------------- 162 163 procedure Lock_Read_Only (Object : Protection_Access) is 164 Ceiling_Violation : Boolean; 165 166 begin 167 -- If pragma Detect_Blocking is active then, as described in the ARM 168 -- 9.5.1, par. 15, we must check whether this is an external call on 169 -- protected subprogram with the same target object as that of the 170 -- protected action that is currently in progress (i.e., if the caller 171 -- is already the protected object's owner). If this is the case hence 172 -- Program_Error must be raised. 173 -- 174 -- Note that in this case (getting read access), several tasks may have 175 -- read ownership of the protected object, so that this method of 176 -- storing the (single) protected object's owner does not work reliably 177 -- for read locks. However, this is the approach taken for two major 178 -- reasons: first, this function is not currently being used (it is 179 -- provided for possible future use), and second, it largely simplifies 180 -- the implementation. 181 182 if Detect_Blocking and then Object.Owner = Self then 183 raise Program_Error; 184 end if; 185 186 Read_Lock (Object.L'Access, Ceiling_Violation); 187 188 if Parameters.Runtime_Traces then 189 Send_Trace_Info (PO_Lock); 190 end if; 191 192 if Ceiling_Violation then 193 raise Program_Error; 194 end if; 195 196 -- We are entering in a protected action, so we increase the protected 197 -- object nesting level (if pragma Detect_Blocking is active). 198 199 if Detect_Blocking then 200 declare 201 Self_Id : constant Task_Id := Self; 202 begin 203 -- Update the protected object's owner 204 205 Object.Owner := Self_Id; 206 207 -- Increase protected object nesting level 208 209 Self_Id.Common.Protected_Action_Nesting := 210 Self_Id.Common.Protected_Action_Nesting + 1; 211 end; 212 end if; 213 end Lock_Read_Only; 214 215 ----------------- 216 -- Set_Ceiling -- 217 ----------------- 218 219 procedure Set_Ceiling 220 (Object : Protection_Access; 221 Prio : System.Any_Priority) is 222 begin 223 Object.New_Ceiling := Prio; 224 end Set_Ceiling; 225 226 ------------ 227 -- Unlock -- 228 ------------ 229 230 procedure Unlock (Object : Protection_Access) is 231 begin 232 -- We are exiting from a protected action, so that we decrease the 233 -- protected object nesting level (if pragma Detect_Blocking is 234 -- active), and remove ownership of the protected object. 235 236 if Detect_Blocking then 237 declare 238 Self_Id : constant Task_Id := Self; 239 240 begin 241 -- Calls to this procedure can only take place when being within 242 -- a protected action and when the caller is the protected 243 -- object's owner. 244 245 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 246 and then Object.Owner = Self_Id); 247 248 -- Remove ownership of the protected object 249 250 Object.Owner := Null_Task; 251 252 -- We are exiting from a protected action, so we decrease the 253 -- protected object nesting level. 254 255 Self_Id.Common.Protected_Action_Nesting := 256 Self_Id.Common.Protected_Action_Nesting - 1; 257 end; 258 end if; 259 260 -- Before releasing the mutex we must actually update its ceiling 261 -- priority if it has been changed. 262 263 if Object.New_Ceiling /= Object.Ceiling then 264 if Locking_Policy = 'C' then 265 System.Task_Primitives.Operations.Set_Ceiling 266 (Object.L'Access, Object.New_Ceiling); 267 end if; 268 269 Object.Ceiling := Object.New_Ceiling; 270 end if; 271 272 Unlock (Object.L'Access); 273 274 if Parameters.Runtime_Traces then 275 Send_Trace_Info (PO_Unlock); 276 end if; 277 end Unlock; 278 279begin 280 -- Ensure that tasking is initialized, as well as tasking soft links 281 -- when using protected objects. 282 283 Tasking.Initialize; 284 System.Soft_Links.Tasking.Init_Tasking_Soft_Links; 285end System.Tasking.Protected_Objects; 286