1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.MONOTONIC -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- 10-- -- 11-- GNARL 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 3, 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is the Monotonic version of this package for Posix and Linux targets. 33 34separate (System.Task_Primitives.Operations) 35package body Monotonic is 36 37 ----------------------- 38 -- Local Subprograms -- 39 ----------------------- 40 41 procedure Compute_Deadline 42 (Time : Duration; 43 Mode : ST.Delay_Modes; 44 Check_Time : out Duration; 45 Abs_Time : out Duration); 46 -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by 47 -- Time and Mode, compute the current clock reading (Check_Time), and the 48 -- target absolute and relative clock readings (Abs_Time). The 49 -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time 50 -- is always that of CLOCK_RT_Ada. 51 52 --------------------- 53 -- Monotonic_Clock -- 54 --------------------- 55 56 function Monotonic_Clock return Duration is 57 TS : aliased timespec; 58 Result : Interfaces.C.int; 59 begin 60 Result := clock_gettime 61 (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access); 62 pragma Assert (Result = 0); 63 64 return To_Duration (TS); 65 end Monotonic_Clock; 66 67 ------------------- 68 -- RT_Resolution -- 69 ------------------- 70 71 function RT_Resolution return Duration is 72 TS : aliased timespec; 73 Result : Interfaces.C.int; 74 75 begin 76 Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); 77 pragma Assert (Result = 0); 78 79 return To_Duration (TS); 80 end RT_Resolution; 81 82 ---------------------- 83 -- Compute_Deadline -- 84 ---------------------- 85 86 procedure Compute_Deadline 87 (Time : Duration; 88 Mode : ST.Delay_Modes; 89 Check_Time : out Duration; 90 Abs_Time : out Duration) 91 is 92 begin 93 Check_Time := Monotonic_Clock; 94 95 -- Relative deadline 96 97 if Mode = Relative then 98 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; 99 100 pragma Warnings (Off); 101 -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile 102 -- time known. 103 104 -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada) 105 106 elsif Mode = Absolute_RT 107 or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME 108 then 109 pragma Warnings (On); 110 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); 111 112 -- Absolute deadline specified using the calendar clock, in the 113 -- case where it is not the same as the tasking clock: compensate for 114 -- difference between clock epochs (Base_Time - Base_Cal_Time). 115 116 else 117 declare 118 Cal_Check_Time : constant Duration := OS_Primitives.Clock; 119 RT_Time : constant Duration := 120 Time + Check_Time - Cal_Check_Time; 121 122 begin 123 Abs_Time := 124 Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time); 125 126 end; 127 end if; 128 end Compute_Deadline; 129 130 ----------------- 131 -- Timed_Sleep -- 132 ----------------- 133 134 -- This is for use within the run-time system, so abort is 135 -- assumed to be already deferred, and the caller should be 136 -- holding its own ATCB lock. 137 138 procedure Timed_Sleep 139 (Self_ID : ST.Task_Id; 140 Time : Duration; 141 Mode : ST.Delay_Modes; 142 Reason : System.Tasking.Task_States; 143 Timedout : out Boolean; 144 Yielded : out Boolean) 145 is 146 pragma Unreferenced (Reason); 147 148 Base_Time : Duration; 149 Check_Time : Duration; 150 Abs_Time : Duration; 151 P_Abs_Time : Duration; 152 153 Request : aliased timespec; 154 Result : Interfaces.C.int; 155 Exit_Outer : Boolean := False; 156 157 begin 158 Timedout := True; 159 Yielded := False; 160 161 Compute_Deadline 162 (Time => Time, 163 Mode => Mode, 164 Check_Time => Check_Time, 165 Abs_Time => Abs_Time); 166 Base_Time := Check_Time; 167 168 -- To keep a sensible Max_Sensible_Delay on a target whose system 169 -- maximum is less than sensible, we split the delay into manageable 170 -- chunks of time less than or equal to the Max_System_Delay. 171 172 if Abs_Time > Check_Time then 173 174 Outer : loop 175 176 pragma Warnings (Off, "condition is always *"); 177 if Max_System_Delay < Max_Sensible_Delay and then 178 Abs_Time > Check_Time + Max_System_Delay 179 then 180 P_Abs_Time := Check_Time + Max_System_Delay; 181 else 182 P_Abs_Time := Abs_Time; 183 Exit_Outer := True; 184 end if; 185 pragma Warnings (On); 186 187 Request := To_Timespec (P_Abs_Time); 188 189 Inner : loop 190 exit Outer 191 when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 192 193 Result := 194 pthread_cond_timedwait 195 (cond => Self_ID.Common.LL.CV'Access, 196 mutex => Self_ID.Common.LL.L'Access, 197 abstime => Request'Access); 198 199 case Result is 200 when 0 | EINTR => 201 -- Somebody may have called Wakeup for us 202 Timedout := False; 203 exit Outer; 204 205 when ETIMEDOUT => 206 exit Outer when Exit_Outer; 207 Check_Time := Monotonic_Clock; 208 exit Inner; 209 210 when others => 211 pragma Assert (False); 212 213 end case; 214 215 exit Outer 216 when Abs_Time <= Check_Time or else Check_Time < Base_Time; 217 218 end loop Inner; 219 end loop Outer; 220 end if; 221 end Timed_Sleep; 222 223 ----------------- 224 -- Timed_Delay -- 225 ----------------- 226 227 -- This is for use in implementing delay statements, so we assume the 228 -- caller is abort-deferred but is holding no locks. 229 230 procedure Timed_Delay 231 (Self_ID : ST.Task_Id; 232 Time : Duration; 233 Mode : ST.Delay_Modes) 234 is 235 Base_Time : Duration; 236 Check_Time : Duration; 237 Abs_Time : Duration; 238 P_Abs_Time : Duration; 239 Request : aliased timespec; 240 241 Result : Interfaces.C.int; 242 Exit_Outer : Boolean := False; 243 244 begin 245 Write_Lock (Self_ID); 246 247 Compute_Deadline 248 (Time => Time, 249 Mode => Mode, 250 Check_Time => Check_Time, 251 Abs_Time => Abs_Time); 252 Base_Time := Check_Time; 253 254 -- To keep a sensible Max_Sensible_Delay on a target whose system 255 -- maximum is less than sensible, we split the delay into manageable 256 -- chunks of time less than or equal to the Max_System_Delay. 257 258 if Abs_Time > Check_Time then 259 Self_ID.Common.State := Delay_Sleep; 260 261 Outer : loop 262 263 pragma Warnings (Off, "condition is always *"); 264 if Max_System_Delay < Max_Sensible_Delay and then 265 Abs_Time > Check_Time + Max_System_Delay 266 then 267 P_Abs_Time := Check_Time + Max_System_Delay; 268 else 269 P_Abs_Time := Abs_Time; 270 Exit_Outer := True; 271 end if; 272 pragma Warnings (On); 273 274 Request := To_Timespec (P_Abs_Time); 275 276 Inner : loop 277 exit Outer 278 when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 279 280 Result := 281 pthread_cond_timedwait 282 (cond => Self_ID.Common.LL.CV'Access, 283 mutex => Self_ID.Common.LL.L'Access, 284 abstime => Request'Access); 285 286 case Result is 287 when ETIMEDOUT => 288 exit Outer when Exit_Outer; 289 Check_Time := Monotonic_Clock; 290 exit Inner; 291 292 when 0 | EINTR => null; 293 294 when others => 295 pragma Assert (False); 296 297 end case; 298 299 exit Outer 300 when Abs_Time <= Check_Time or else Check_Time < Base_Time; 301 302 end loop Inner; 303 end loop Outer; 304 305 Self_ID.Common.State := Runnable; 306 end if; 307 308 Unlock (Self_ID); 309 pragma Unreferenced (Result); 310 Result := sched_yield; 311 end Timed_Delay; 312 313end Monotonic; 314