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