diff options
| -rw-r--r-- | gcc/ada/s-taprop-solaris.adb | 148 |
1 files changed, 72 insertions, 76 deletions
diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 002064c..9da267e 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -141,7 +141,7 @@ package body System.Task_Primitives.Operations is -- External Configuration Values -- ----------------------------------- - Time_Slice_Val : Interfaces.C.long; + Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); Locking_Policy : Character; @@ -151,7 +151,7 @@ package body System.Task_Primitives.Operations is pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). + -- Used to identified fake tasks (i.e., non-Ada Threads) ----------------------- -- Local Subprograms -- @@ -216,7 +216,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (Environment_Task : Task_Id); pragma Inline (Initialize); - -- Initialize various data needed by this package. + -- Initialize various data needed by this package function Is_Valid_Task return Boolean; pragma Inline (Is_Valid_Task); @@ -224,23 +224,23 @@ package body System.Task_Primitives.Operations is procedure Set (Self_Id : Task_Id); pragma Inline (Set); - -- Set the self id for the current task. + -- Set the self id for the current task function Self return Task_Id; pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. + -- Return a pointer to the Ada Task Control Block of the calling task end Specific; package body Specific is separate; - -- The body of this package is target specific. + -- The body of this package is target specific --------------------------------- -- Support for foreign threads -- --------------------------------- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread. + -- Allocate and Initialize a new ATCB for the current Thread function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is separate; @@ -353,6 +353,7 @@ package body System.Task_Primitives.Operations is begin if Proc_Acc.all'Length /= 0 then + -- Environment variable is defined Last_Proc := Num_Procs - 1; @@ -438,11 +439,13 @@ package body System.Task_Primitives.Operations is -- If a pragma Time_Slice is specified, takes the value in account if Time_Slice_Val > 0 then + -- Convert Time_Slice_Val (microseconds) into seconds and -- nanoseconds - Secs := Time_Slice_Val / 1_000_000; - Nsecs := (Time_Slice_Val rem 1_000_000) * 1_000; + Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000); + Nsecs := + Interfaces.C.long ((Time_Slice_Val rem 1_000_000) * 1_000); -- Otherwise, default to no time slicing (i.e run until blocked) @@ -451,7 +454,7 @@ package body System.Task_Primitives.Operations is Nsecs := RT_TQINF; end if; - -- Get the real time class id. + -- Get the real time class id Class_Info.pc_clname (1) := 'R'; Class_Info.pc_clname (2) := 'T'; @@ -482,7 +485,7 @@ package body System.Task_Primitives.Operations is Specific.Set (Environment_Task); - -- Initialize the lock used to synchronize chain of all ATCBs. + -- Initialize the lock used to synchronize chain of all ATCBs Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); @@ -699,7 +702,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); @@ -710,7 +712,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (T : Task_Id) is Result : Interfaces.C.int; - begin if not Single_Lock then pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access))); @@ -820,7 +821,6 @@ package body System.Task_Primitives.Operations is thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); else - -- The task is bound to a LWP, use priocntl -- ??? TBD @@ -942,7 +942,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int := 0; begin - -- Give the task a unique serial number. + -- Give the task a unique serial number Self_ID.Serial_Number := Next_Serial_Number; Next_Serial_Number := Next_Serial_Number + 1; @@ -1132,21 +1132,19 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = EINTR); end Sleep; - -- Note that we are relying heaviliy here on the GNAT feature - -- that Calendar.Time, System.Real_Time.Time, Duration, and - -- System.Real_Time.Time_Span are all represented in the same + -- Note that we are relying heaviliy here on GNAT represting Calendar.Time, + -- System.Real_Time.Time, Duration, System.Real_Time.Time_Span in the same -- way, i.e., as a 64-bit count of nanoseconds. - -- This allows us to always pass the timeout value as a Duration. + -- This allows us to always pass the timeout value as a Duration -- ??? - -- We are taking liberties here with the semantics of the delays. - -- That is, we make no distinction between delays on the Calendar clock - -- and delays on the Real_Time clock. That is technically incorrect, if - -- the Calendar clock happens to be reset or adjusted. - -- To solve this defect will require modification to the compiler - -- interface, so that it can pass through more information, to tell - -- us here which clock to use! + -- We are taking liberties here with the semantics of the delays. That is, + -- we make no distinction between delays on the Calendar clock and delays + -- on the Real_Time clock. That is technically incorrect, if the Calendar + -- clock happens to be reset or adjusted. To solve this defect will require + -- modification to the compiler interface, so that it can pass through more + -- information, to tell us here which clock to use! -- cond_timedwait will return if any of the following happens: -- 1) some other task did cond_signal on this condition variable @@ -1161,47 +1159,42 @@ package body System.Task_Primitives.Operations is -- UNIX calls this an "interrupted" system call. -- In this case, the return value is EINTR - -- If the cond_timedwait returns 0 or EINTR, it is still - -- possible that the time has actually expired, and by chance - -- a signal or cond_signal occurred at around the same time. - - -- We have also observed that on some OS's the value ETIME - -- will be returned, but the clock will show that the full delay - -- has not yet expired. - - -- For these reasons, we need to check the clock after return - -- from cond_timedwait. If the time has expired, we will set - -- Timedout = True. - - -- This check might be omitted for systems on which the - -- cond_timedwait() never returns early or wakes up spuriously. - - -- Annex D requires that completion of a delay cause the task - -- to go to the end of its priority queue, regardless of whether - -- the task actually was suspended by the delay. Since - -- cond_timedwait does not do this on Solaris, we add a call - -- to thr_yield at the end. We might do this at the beginning, - -- instead, but then the round-robin effect would not be the - -- same; the delayed task would be ahead of other tasks of the - -- same priority that awoke while it was sleeping. - - -- For Timed_Sleep, we are expecting possible cond_signals - -- to indicate other events (e.g., completion of a RV or - -- completion of the abortable part of an async. select), - -- we want to always return if interrupted. The caller will - -- be responsible for checking the task state to see whether - -- the wakeup was spurious, and to go back to sleep again - -- in that case. We don't need to check for pending abort - -- or priority change on the way in our out; that is the - -- caller's responsibility. - - -- For Timed_Delay, we are not expecting any cond_signals or - -- other interruptions, except for priority changes and aborts. - -- Therefore, we don't want to return unless the delay has - -- actually expired, or the call has been aborted. In this - -- case, since we want to implement the entire delay statement - -- semantics, we do need to check for pending abort and priority - -- changes. We can quietly handle priority changes inside the + -- If the cond_timedwait returns 0 or EINTR, it is still possible that the + -- time has actually expired, and by chance a signal or cond_signal + -- occurred at around the same time. + + -- We have also observed that on some OS's the value ETIME will be + -- returned, but the clock will show that the full delay has not yet + -- expired. + + -- For these reasons, we need to check the clock after return from + -- cond_timedwait. If the time has expired, we will set Timedout = True. + + -- This check might be omitted for systems on which the cond_timedwait() + -- never returns early or wakes up spuriously. + + -- Annex D requires that completion of a delay cause the task to go to the + -- end of its priority queue, regardless of whether the task actually was + -- suspended by the delay. Since cond_timedwait does not do this on + -- Solaris, we add a call to thr_yield at the end. We might do this at the + -- beginning, instead, but then the round-robin effect would not be the + -- same; the delayed task would be ahead of other tasks of the same + -- priority that awoke while it was sleeping. + + -- For Timed_Sleep, we are expecting possible cond_signals to indicate + -- other events (e.g., completion of a RV or completion of the abortable + -- part of an async. select), we want to always return if interrupted. The + -- caller will be responsible for checking the task state to see whether + -- the wakeup was spurious, and to go back to sleep again in that case. We + -- don't need to check for pending abort or priority change on the way in + -- our out; that is the caller's responsibility. + + -- For Timed_Delay, we are not expecting any cond_signals or other + -- interruptions, except for priority changes and aborts. Therefore, we + -- don't want to return unless the delay has actually expired, or the call + -- has been aborted. In this case, since we want to implement the entire + -- delay statement semantics, we do need to check for pending abort and + -- priority changes. We can quietly handle priority changes inside the -- procedure, since there is no entry-queue reordering involved. ----------------- @@ -1273,9 +1266,9 @@ package body System.Task_Primitives.Operations is ----------------- procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) is Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; @@ -1313,11 +1306,15 @@ package body System.Task_Primitives.Operations is exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Result := cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock.L'Access, Request'Access); + Result := cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock.L'Access, + Request'Access); else - Result := cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L.L'Access, Request'Access); + Result := cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L.L'Access, + Request'Access); end if; Yielded := True; @@ -1824,8 +1821,7 @@ package body System.Task_Primitives.Operations is function Check_Exit (Self_ID : Task_Id) return Boolean is begin - -- Check that caller is just holding Global_Task_Lock - -- and no other locks + -- Check that caller is just holding Global_Task_Lock and no other locks if Self_ID.Common.LL.Locks = null then return False; |