1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4--                                                                          --
5--     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--         Copyright (C) 1992-2019, 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 a Solaris (native) version of this package
33
34--  This package contains all the GNULL primitives that interface directly with
35--  the underlying OS.
36
37pragma Polling (Off);
38--  Turn off polling, we do not want ATC polling to take place during tasking
39--  operations. It causes infinite loops and other problems.
40
41with Interfaces.C;
42
43with System.Multiprocessors;
44with System.Tasking.Debug;
45with System.Interrupt_Management;
46with System.OS_Constants;
47with System.OS_Primitives;
48with System.Task_Info;
49
50pragma Warnings (Off);
51with System.OS_Lib;
52pragma Warnings (On);
53
54with System.Soft_Links;
55--  We use System.Soft_Links instead of System.Tasking.Initialization
56--  because the later is a higher level package that we shouldn't depend on.
57--  For example when using the restricted run time, it is replaced by
58--  System.Tasking.Restricted.Stages.
59
60package body System.Task_Primitives.Operations is
61
62   package OSC renames System.OS_Constants;
63   package SSL renames System.Soft_Links;
64
65   use System.Tasking.Debug;
66   use System.Tasking;
67   use Interfaces.C;
68   use System.OS_Interface;
69   use System.Parameters;
70   use System.OS_Primitives;
71
72   ----------------
73   -- Local Data --
74   ----------------
75
76   --  The following are logically constants, but need to be initialized
77   --  at run time.
78
79   Environment_Task_Id : Task_Id;
80   --  A variable to hold Task_Id for the environment task.
81   --  If we use this variable to get the Task_Id, we need the following
82   --  ATCB_Key only for non-Ada threads.
83
84   Unblocked_Signal_Mask : aliased sigset_t;
85   --  The set of signals that should unblocked in all tasks
86
87   ATCB_Key : aliased thread_key_t;
88   --  Key used to find the Ada Task_Id associated with a thread,
89   --  at least for C threads unknown to the Ada run-time system.
90
91   Single_RTS_Lock : aliased RTS_Lock;
92   --  This is a lock to allow only one thread of control in the RTS at
93   --  a time; it is used to execute in mutual exclusion from all other tasks.
94   --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
95
96   Next_Serial_Number : Task_Serial_Number := 100;
97   --  We start at 100, to reserve some special values for
98   --  using in error checking.
99   --  The following are internal configuration constants needed.
100
101   Abort_Handler_Installed : Boolean := False;
102   --  True if a handler for the abort signal is installed
103
104   Null_Thread_Id : constant Thread_Id := Thread_Id'Last;
105   --  Constant to indicate that the thread identifier has not yet been
106   --  initialized.
107
108   ----------------------
109   -- Priority Support --
110   ----------------------
111
112   Priority_Ceiling_Emulation : constant Boolean := True;
113   --  controls whether we emulate priority ceiling locking
114
115   --  To get a scheduling close to annex D requirements, we use the real-time
116   --  class provided for LWPs and map each task/thread to a specific and
117   --  unique LWP (there is 1 thread per LWP, and 1 LWP per thread).
118
119   --  The real time class can only be set when the process has root
120   --  privileges, so in the other cases, we use the normal thread scheduling
121   --  and priority handling.
122
123   Using_Real_Time_Class : Boolean := False;
124   --  indicates whether the real time class is being used (i.e. the process
125   --  has root privileges).
126
127   Prio_Param : aliased struct_pcparms;
128   --  Hold priority info (Real_Time) initialized during the package
129   --  elaboration.
130
131   -----------------------------------
132   -- External Configuration Values --
133   -----------------------------------
134
135   Time_Slice_Val : Integer;
136   pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
137
138   Locking_Policy : Character;
139   pragma Import (C, Locking_Policy, "__gl_locking_policy");
140
141   Dispatching_Policy : Character;
142   pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
143
144   Foreign_Task_Elaborated : aliased Boolean := True;
145   --  Used to identified fake tasks (i.e., non-Ada Threads)
146
147   -----------------------
148   -- Local Subprograms --
149   -----------------------
150
151   function sysconf (name : System.OS_Interface.int) return processorid_t;
152   pragma Import (C, sysconf, "sysconf");
153
154   SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14;
155
156   function Num_Procs
157     (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
158      return processorid_t renames sysconf;
159
160   procedure Abort_Handler
161     (Sig     : Signal;
162      Code    : not null access siginfo_t;
163      Context : not null access ucontext_t);
164   --  Target-dependent binding of inter-thread Abort signal to
165   --  the raising of the Abort_Signal exception.
166   --  See also comments in 7staprop.adb
167
168   ------------
169   -- Checks --
170   ------------
171
172   function Check_Initialize_Lock
173     (L     : Lock_Ptr;
174      Level : Lock_Level) return Boolean;
175   pragma Inline (Check_Initialize_Lock);
176
177   function Check_Lock (L : Lock_Ptr) return Boolean;
178   pragma Inline (Check_Lock);
179
180   function Record_Lock (L : Lock_Ptr) return Boolean;
181   pragma Inline (Record_Lock);
182
183   function Check_Sleep (Reason : Task_States) return Boolean;
184   pragma Inline (Check_Sleep);
185
186   function Record_Wakeup
187     (L      : Lock_Ptr;
188      Reason : Task_States) return Boolean;
189   pragma Inline (Record_Wakeup);
190
191   function Check_Wakeup
192     (T      : Task_Id;
193      Reason : Task_States) return Boolean;
194   pragma Inline (Check_Wakeup);
195
196   function Check_Unlock (L : Lock_Ptr) return Boolean;
197   pragma Inline (Check_Unlock);
198
199   function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
200   pragma Inline (Check_Finalize_Lock);
201
202   --------------------
203   -- Local Packages --
204   --------------------
205
206   package Specific is
207
208      procedure Initialize (Environment_Task : Task_Id);
209      pragma Inline (Initialize);
210      --  Initialize various data needed by this package
211
212      function Is_Valid_Task return Boolean;
213      pragma Inline (Is_Valid_Task);
214      --  Does executing thread have a TCB?
215
216      procedure Set (Self_Id : Task_Id);
217      pragma Inline (Set);
218      --  Set the self id for the current task
219
220      function Self return Task_Id;
221      pragma Inline (Self);
222      --  Return a pointer to the Ada Task Control Block of the calling task
223
224   end Specific;
225
226   package body Specific is separate;
227   --  The body of this package is target specific
228
229   ----------------------------------
230   -- ATCB allocation/deallocation --
231   ----------------------------------
232
233   package body ATCB_Allocation is separate;
234   --  The body of this package is shared across several targets
235
236   ---------------------------------
237   -- Support for foreign threads --
238   ---------------------------------
239
240   function Register_Foreign_Thread
241     (Thread         : Thread_Id;
242      Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id;
243   --  Allocate and initialize a new ATCB for the current Thread. The size of
244   --  the secondary stack can be optionally specified.
245
246   function Register_Foreign_Thread
247     (Thread         : Thread_Id;
248      Sec_Stack_Size : Size_Type := Unspecified_Size)
249     return Task_Id is separate;
250
251   ------------
252   -- Checks --
253   ------------
254
255   Check_Count  : Integer := 0;
256   Lock_Count   : Integer := 0;
257   Unlock_Count : Integer := 0;
258
259   -------------------
260   -- Abort_Handler --
261   -------------------
262
263   procedure Abort_Handler
264     (Sig     : Signal;
265      Code    : not null access siginfo_t;
266      Context : not null access ucontext_t)
267   is
268      pragma Unreferenced (Sig);
269      pragma Unreferenced (Code);
270      pragma Unreferenced (Context);
271
272      Self_ID : constant Task_Id := Self;
273      Old_Set : aliased sigset_t;
274
275      Result : Interfaces.C.int;
276      pragma Warnings (Off, Result);
277
278   begin
279      --  It's not safe to raise an exception when using GCC ZCX mechanism.
280      --  Note that we still need to install a signal handler, since in some
281      --  cases (e.g. shutdown of the Server_Task in System.Interrupts) we
282      --  need to send the Abort signal to a task.
283
284      if ZCX_By_Default then
285         return;
286      end if;
287
288      if Self_ID.Deferral_Level = 0
289        and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
290        and then not Self_ID.Aborting
291      then
292         Self_ID.Aborting := True;
293
294         --  Make sure signals used for RTS internal purpose are unmasked
295
296         Result :=
297           thr_sigsetmask
298             (SIG_UNBLOCK,
299              Unblocked_Signal_Mask'Unchecked_Access,
300              Old_Set'Unchecked_Access);
301         pragma Assert (Result = 0);
302
303         raise Standard'Abort_Signal;
304      end if;
305   end Abort_Handler;
306
307   -----------------
308   -- Stack_Guard --
309   -----------------
310
311   --  The underlying thread system sets a guard page at the
312   --  bottom of a thread stack, so nothing is needed.
313
314   procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
315      pragma Unreferenced (T);
316      pragma Unreferenced (On);
317   begin
318      null;
319   end Stack_Guard;
320
321   -------------------
322   -- Get_Thread_Id --
323   -------------------
324
325   function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
326   begin
327      return T.Common.LL.Thread;
328   end Get_Thread_Id;
329
330   ----------------
331   -- Initialize --
332   ----------------
333
334   procedure Initialize (Environment_Task : ST.Task_Id) is
335      act     : aliased struct_sigaction;
336      old_act : aliased struct_sigaction;
337      Tmp_Set : aliased sigset_t;
338      Result  : Interfaces.C.int;
339
340      procedure Configure_Processors;
341      --  Processors configuration
342      --  The user can specify a processor which the program should run
343      --  on to emulate a single-processor system. This can be easily
344      --  done by setting environment variable GNAT_PROCESSOR to one of
345      --  the following :
346      --
347      --    -2 : use the default configuration (run the program on all
348      --         available processors) - this is the same as having
349      --         GNAT_PROCESSOR unset
350      --    -1 : let the RTS choose one processor and run the program on
351      --         that processor
352      --    0 .. Last_Proc : run the program on the specified processor
353      --
354      --  Last_Proc is equal to the value of the system variable
355      --  _SC_NPROCESSORS_CONF, minus one.
356
357      procedure Configure_Processors is
358         Proc_Acc  : constant System.OS_Lib.String_Access :=
359                       System.OS_Lib.Getenv ("GNAT_PROCESSOR");
360         Proc      : aliased processorid_t;  --  User processor #
361         Last_Proc : processorid_t;          --  Last processor #
362
363      begin
364         if Proc_Acc.all'Length /= 0 then
365
366            --  Environment variable is defined
367
368            Last_Proc := Num_Procs - 1;
369
370            if Last_Proc /= -1 then
371               Proc := processorid_t'Value (Proc_Acc.all);
372
373               if Proc <= -2  or else Proc > Last_Proc then
374
375                  --  Use the default configuration
376
377                  null;
378
379               elsif Proc = -1 then
380
381                  --  Choose a processor
382
383                  Result := 0;
384                  while Proc < Last_Proc loop
385                     Proc := Proc + 1;
386                     Result := p_online (Proc, PR_STATUS);
387                     exit when Result = PR_ONLINE;
388                  end loop;
389
390                  pragma Assert (Result = PR_ONLINE);
391                  Result := processor_bind (P_PID, P_MYID, Proc, null);
392                  pragma Assert (Result = 0);
393
394               else
395                  --  Use user processor
396
397                  Result := processor_bind (P_PID, P_MYID, Proc, null);
398                  pragma Assert (Result = 0);
399               end if;
400            end if;
401         end if;
402
403      exception
404         when Constraint_Error =>
405
406            --  Illegal environment variable GNAT_PROCESSOR - ignored
407
408            null;
409      end Configure_Processors;
410
411      function State
412        (Int : System.Interrupt_Management.Interrupt_ID) return Character;
413      pragma Import (C, State, "__gnat_get_interrupt_state");
414      --  Get interrupt state.  Defined in a-init.c
415      --  The input argument is the interrupt number,
416      --  and the result is one of the following:
417
418      Default : constant Character := 's';
419      --    'n'   this interrupt not set by any Interrupt_State pragma
420      --    'u'   Interrupt_State pragma set state to User
421      --    'r'   Interrupt_State pragma set state to Runtime
422      --    's'   Interrupt_State pragma set state to System (use "default"
423      --           system handler)
424
425   --  Start of processing for Initialize
426
427   begin
428      Environment_Task_Id := Environment_Task;
429
430      Interrupt_Management.Initialize;
431
432      --  Prepare the set of signals that should unblocked in all tasks
433
434      Result := sigemptyset (Unblocked_Signal_Mask'Access);
435      pragma Assert (Result = 0);
436
437      for J in Interrupt_Management.Interrupt_ID loop
438         if System.Interrupt_Management.Keep_Unmasked (J) then
439            Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
440            pragma Assert (Result = 0);
441         end if;
442      end loop;
443
444      if Dispatching_Policy = 'F' then
445         declare
446            Result      : Interfaces.C.long;
447            Class_Info  : aliased struct_pcinfo;
448            Secs, Nsecs : Interfaces.C.long;
449
450         begin
451            --  If a pragma Time_Slice is specified, takes the value in account
452
453            if Time_Slice_Val > 0 then
454
455               --  Convert Time_Slice_Val (microseconds) to seconds/nanosecs
456
457               Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000);
458               Nsecs :=
459                 Interfaces.C.long ((Time_Slice_Val rem 1_000_000) * 1_000);
460
461            --  Otherwise, default to no time slicing (i.e run until blocked)
462
463            else
464               Secs := RT_TQINF;
465               Nsecs := RT_TQINF;
466            end if;
467
468            --  Get the real time class id
469
470            Class_Info.pc_clname (1) := 'R';
471            Class_Info.pc_clname (2) := 'T';
472            Class_Info.pc_clname (3) := ASCII.NUL;
473
474            Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
475              Class_Info'Address);
476
477            --  Request the real time class
478
479            Prio_Param.pc_cid := Class_Info.pc_cid;
480            Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
481            Prio_Param.rt_tqsecs := Secs;
482            Prio_Param.rt_tqnsecs := Nsecs;
483
484            Result :=
485              priocntl
486                (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address);
487
488            Using_Real_Time_Class := Result /= -1;
489         end;
490      end if;
491
492      Specific.Initialize (Environment_Task);
493
494      --  The following is done in Enter_Task, but this is too late for the
495      --  Environment Task, since we need to call Self in Check_Locks when
496      --  the run time is compiled with assertions on.
497
498      Specific.Set (Environment_Task);
499
500      --  Initialize the lock used to synchronize chain of all ATCBs
501
502      Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
503
504      --  Make environment task known here because it doesn't go through
505      --  Activate_Tasks, which does it for all other tasks.
506
507      Known_Tasks (Known_Tasks'First) := Environment_Task;
508      Environment_Task.Known_Tasks_Index := Known_Tasks'First;
509
510      Enter_Task (Environment_Task);
511
512      Configure_Processors;
513
514      if State
515          (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
516      then
517         --  Set sa_flags to SA_NODEFER so that during the handler execution
518         --  we do not change the Signal_Mask to be masked for the Abort_Signal
519         --  This is a temporary fix to the problem that the Signal_Mask is
520         --  not restored after the exception (longjmp) from the handler.
521         --  The right fix should be made in sigsetjmp so that we save
522         --  the Signal_Set and restore it after a longjmp.
523         --  In that case, this field should be changed back to 0. ???
524
525         act.sa_flags := 16;
526
527         act.sa_handler := Abort_Handler'Address;
528         Result := sigemptyset (Tmp_Set'Access);
529         pragma Assert (Result = 0);
530         act.sa_mask := Tmp_Set;
531
532         Result :=
533           sigaction
534             (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
535              act'Unchecked_Access,
536              old_act'Unchecked_Access);
537         pragma Assert (Result = 0);
538         Abort_Handler_Installed := True;
539      end if;
540   end Initialize;
541
542   ---------------------
543   -- Initialize_Lock --
544   ---------------------
545
546   --  Note: mutexes and cond_variables needed per-task basis are initialized
547   --  in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
548   --  as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
549   --  status change of RTS. Therefore raising Storage_Error in the following
550   --  routines should be able to be handled safely.
551
552   procedure Initialize_Lock
553     (Prio : System.Any_Priority;
554      L    : not null access Lock)
555   is
556      Result : Interfaces.C.int;
557
558   begin
559      pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level));
560
561      if Priority_Ceiling_Emulation then
562         L.Ceiling := Prio;
563      end if;
564
565      Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
566      pragma Assert (Result = 0 or else Result = ENOMEM);
567
568      if Result = ENOMEM then
569         raise Storage_Error with "Failed to allocate a lock";
570      end if;
571   end Initialize_Lock;
572
573   procedure Initialize_Lock
574     (L     : not null access RTS_Lock;
575      Level : Lock_Level)
576   is
577      Result : Interfaces.C.int;
578
579   begin
580      pragma Assert
581        (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
582      Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
583      pragma Assert (Result = 0 or else Result = ENOMEM);
584
585      if Result = ENOMEM then
586         raise Storage_Error with "Failed to allocate a lock";
587      end if;
588   end Initialize_Lock;
589
590   -------------------
591   -- Finalize_Lock --
592   -------------------
593
594   procedure Finalize_Lock (L : not null access Lock) is
595      Result : Interfaces.C.int;
596   begin
597      pragma Assert (Check_Finalize_Lock (Lock_Ptr (L)));
598      Result := mutex_destroy (L.L'Access);
599      pragma Assert (Result = 0);
600   end Finalize_Lock;
601
602   procedure Finalize_Lock (L : not null access RTS_Lock) is
603      Result : Interfaces.C.int;
604   begin
605      pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
606      Result := mutex_destroy (L.L'Access);
607      pragma Assert (Result = 0);
608   end Finalize_Lock;
609
610   ----------------
611   -- Write_Lock --
612   ----------------
613
614   procedure Write_Lock
615     (L                 : not null access Lock;
616      Ceiling_Violation : out Boolean)
617   is
618      Result : Interfaces.C.int;
619
620   begin
621      pragma Assert (Check_Lock (Lock_Ptr (L)));
622
623      if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
624         declare
625            Self_Id        : constant Task_Id := Self;
626            Saved_Priority : System.Any_Priority;
627
628         begin
629            if Self_Id.Common.LL.Active_Priority > L.Ceiling then
630               Ceiling_Violation := True;
631               return;
632            end if;
633
634            Saved_Priority := Self_Id.Common.LL.Active_Priority;
635
636            if Self_Id.Common.LL.Active_Priority < L.Ceiling then
637               Set_Priority (Self_Id, L.Ceiling);
638            end if;
639
640            Result := mutex_lock (L.L'Access);
641            pragma Assert (Result = 0);
642            Ceiling_Violation := False;
643
644            L.Saved_Priority := Saved_Priority;
645         end;
646
647      else
648         Result := mutex_lock (L.L'Access);
649         pragma Assert (Result = 0);
650         Ceiling_Violation := False;
651      end if;
652
653      pragma Assert (Record_Lock (Lock_Ptr (L)));
654   end Write_Lock;
655
656   procedure Write_Lock
657     (L          : not null access RTS_Lock;
658     Global_Lock : Boolean := False)
659   is
660      Result : Interfaces.C.int;
661   begin
662      if not Single_Lock or else Global_Lock then
663         pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
664         Result := mutex_lock (L.L'Access);
665         pragma Assert (Result = 0);
666         pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
667      end if;
668   end Write_Lock;
669
670   procedure Write_Lock (T : Task_Id) is
671      Result : Interfaces.C.int;
672   begin
673      if not Single_Lock then
674         pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
675         Result := mutex_lock (T.Common.LL.L.L'Access);
676         pragma Assert (Result = 0);
677         pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
678      end if;
679   end Write_Lock;
680
681   ---------------
682   -- Read_Lock --
683   ---------------
684
685   procedure Read_Lock
686     (L                 : not null access Lock;
687      Ceiling_Violation : out Boolean) is
688   begin
689      Write_Lock (L, Ceiling_Violation);
690   end Read_Lock;
691
692   ------------
693   -- Unlock --
694   ------------
695
696   procedure Unlock (L : not null access Lock) is
697      Result : Interfaces.C.int;
698
699   begin
700      pragma Assert (Check_Unlock (Lock_Ptr (L)));
701
702      if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
703         declare
704            Self_Id : constant Task_Id := Self;
705
706         begin
707            Result := mutex_unlock (L.L'Access);
708            pragma Assert (Result = 0);
709
710            if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then
711               Set_Priority (Self_Id, L.Saved_Priority);
712            end if;
713         end;
714      else
715         Result := mutex_unlock (L.L'Access);
716         pragma Assert (Result = 0);
717      end if;
718   end Unlock;
719
720   procedure Unlock
721     (L           : not null access RTS_Lock;
722      Global_Lock : Boolean := False)
723   is
724      Result : Interfaces.C.int;
725   begin
726      if not Single_Lock or else Global_Lock then
727         pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
728         Result := mutex_unlock (L.L'Access);
729         pragma Assert (Result = 0);
730      end if;
731   end Unlock;
732
733   procedure Unlock (T : Task_Id) is
734      Result : Interfaces.C.int;
735   begin
736      if not Single_Lock then
737         pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
738         Result := mutex_unlock (T.Common.LL.L.L'Access);
739         pragma Assert (Result = 0);
740      end if;
741   end Unlock;
742
743   -----------------
744   -- Set_Ceiling --
745   -----------------
746
747   --  Dynamic priority ceilings are not supported by the underlying system
748
749   procedure Set_Ceiling
750     (L    : not null access Lock;
751      Prio : System.Any_Priority)
752   is
753      pragma Unreferenced (L, Prio);
754   begin
755      null;
756   end Set_Ceiling;
757
758   --  For the time delay implementation, we need to make sure we
759   --  achieve following criteria:
760
761   --  1) We have to delay at least for the amount requested.
762   --  2) We have to give up CPU even though the actual delay does not
763   --     result in blocking.
764   --  3) Except for restricted run-time systems that do not support
765   --     ATC or task abort, the delay must be interrupted by the
766   --     abort_task operation.
767   --  4) The implementation has to be efficient so that the delay overhead
768   --     is relatively cheap.
769   --  (1)-(3) are Ada requirements. Even though (2) is an Annex-D
770   --     requirement we still want to provide the effect in all cases.
771   --     The reason is that users may want to use short delays to implement
772   --     their own scheduling effect in the absence of language provided
773   --     scheduling policies.
774
775   ---------------------
776   -- Monotonic_Clock --
777   ---------------------
778
779   function Monotonic_Clock return Duration is
780      TS     : aliased timespec;
781      Result : Interfaces.C.int;
782   begin
783      Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
784      pragma Assert (Result = 0);
785      return To_Duration (TS);
786   end Monotonic_Clock;
787
788   -------------------
789   -- RT_Resolution --
790   -------------------
791
792   function RT_Resolution return Duration is
793      TS     : aliased timespec;
794      Result : Interfaces.C.int;
795   begin
796      Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
797      pragma Assert (Result = 0);
798
799      return To_Duration (TS);
800   end RT_Resolution;
801
802   -----------
803   -- Yield --
804   -----------
805
806   procedure Yield (Do_Yield : Boolean := True) is
807   begin
808      if Do_Yield then
809         System.OS_Interface.thr_yield;
810      end if;
811   end Yield;
812
813   -----------
814   -- Self ---
815   -----------
816
817   function Self return Task_Id renames Specific.Self;
818
819   ------------------
820   -- Set_Priority --
821   ------------------
822
823   procedure Set_Priority
824     (T                   : Task_Id;
825      Prio                : System.Any_Priority;
826      Loss_Of_Inheritance : Boolean := False)
827   is
828      pragma Unreferenced (Loss_Of_Inheritance);
829
830      Result : Interfaces.C.int;
831      pragma Unreferenced (Result);
832
833      Param : aliased struct_pcparms;
834
835      use Task_Info;
836
837   begin
838      T.Common.Current_Priority := Prio;
839
840      if Priority_Ceiling_Emulation then
841         T.Common.LL.Active_Priority := Prio;
842      end if;
843
844      if Using_Real_Time_Class then
845         Param.pc_cid := Prio_Param.pc_cid;
846         Param.rt_pri := pri_t (Prio);
847         Param.rt_tqsecs := Prio_Param.rt_tqsecs;
848         Param.rt_tqnsecs := Prio_Param.rt_tqnsecs;
849
850         Result := Interfaces.C.int (
851           priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS,
852             Param'Address));
853
854      else
855         if T.Common.Task_Info /= null
856           and then not T.Common.Task_Info.Bound_To_LWP
857         then
858            --  The task is not bound to a LWP, so use thr_setprio
859
860            Result :=
861              thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
862
863         else
864            --  The task is bound to a LWP, use priocntl
865            --  ??? TBD
866
867            null;
868         end if;
869      end if;
870   end Set_Priority;
871
872   ------------------
873   -- Get_Priority --
874   ------------------
875
876   function Get_Priority (T : Task_Id) return System.Any_Priority is
877   begin
878      return T.Common.Current_Priority;
879   end Get_Priority;
880
881   ----------------
882   -- Enter_Task --
883   ----------------
884
885   procedure Enter_Task (Self_ID : Task_Id) is
886   begin
887      Self_ID.Common.LL.Thread := thr_self;
888      Self_ID.Common.LL.LWP    := lwp_self;
889
890      Set_Task_Affinity (Self_ID);
891      Specific.Set (Self_ID);
892
893      --  We need the above code even if we do direct fetch of Task_Id in Self
894      --  for the main task on Sun, x86 Solaris and for gcc 2.7.2.
895   end Enter_Task;
896
897   -------------------
898   -- Is_Valid_Task --
899   -------------------
900
901   function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
902
903   -----------------------------
904   -- Register_Foreign_Thread --
905   -----------------------------
906
907   function Register_Foreign_Thread return Task_Id is
908   begin
909      if Is_Valid_Task then
910         return Self;
911      else
912         return Register_Foreign_Thread (thr_self);
913      end if;
914   end Register_Foreign_Thread;
915
916   --------------------
917   -- Initialize_TCB --
918   --------------------
919
920   procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
921      Result : Interfaces.C.int := 0;
922
923   begin
924      --  Give the task a unique serial number
925
926      Self_ID.Serial_Number := Next_Serial_Number;
927      Next_Serial_Number := Next_Serial_Number + 1;
928      pragma Assert (Next_Serial_Number /= 0);
929
930      Self_ID.Common.LL.Thread := Null_Thread_Id;
931
932      if not Single_Lock then
933         Result :=
934           mutex_init
935             (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
936         Self_ID.Common.LL.L.Level :=
937           Private_Task_Serial_Number (Self_ID.Serial_Number);
938         pragma Assert (Result = 0 or else Result = ENOMEM);
939      end if;
940
941      if Result = 0 then
942         Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
943         pragma Assert (Result = 0 or else Result = ENOMEM);
944      end if;
945
946      if Result = 0 then
947         Succeeded := True;
948      else
949         if not Single_Lock then
950            Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
951            pragma Assert (Result = 0);
952         end if;
953
954         Succeeded := False;
955      end if;
956   end Initialize_TCB;
957
958   -----------------
959   -- Create_Task --
960   -----------------
961
962   procedure Create_Task
963     (T          : Task_Id;
964      Wrapper    : System.Address;
965      Stack_Size : System.Parameters.Size_Type;
966      Priority   : System.Any_Priority;
967      Succeeded  : out Boolean)
968   is
969      pragma Unreferenced (Priority);
970
971      Result              : Interfaces.C.int;
972      Adjusted_Stack_Size : Interfaces.C.size_t;
973      Opts                : Interfaces.C.int := THR_DETACHED;
974
975      Page_Size           : constant System.Parameters.Size_Type := 4096;
976      --  This constant is for reserving extra space at the
977      --  end of the stack, which can be used by the stack
978      --  checking as guard page. The idea is that we need
979      --  to have at least Stack_Size bytes available for
980      --  actual use.
981
982      use System.Task_Info;
983      use type System.Multiprocessors.CPU_Range;
984
985   begin
986      --  Check whether both Dispatching_Domain and CPU are specified for the
987      --  task, and the CPU value is not contained within the range of
988      --  processors for the domain.
989
990      if T.Common.Domain /= null
991        and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
992        and then
993          (T.Common.Base_CPU not in T.Common.Domain'Range
994            or else not T.Common.Domain (T.Common.Base_CPU))
995      then
996         Succeeded := False;
997         return;
998      end if;
999
1000      Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size);
1001
1002      --  Since the initial signal mask of a thread is inherited from the
1003      --  creator, and the Environment task has all its signals masked, we
1004      --  do not need to manipulate caller's signal mask at this point.
1005      --  All tasks in RTS will have All_Tasks_Mask initially.
1006
1007      if T.Common.Task_Info /= null then
1008         if T.Common.Task_Info.New_LWP then
1009            Opts := Opts + THR_NEW_LWP;
1010         end if;
1011
1012         if T.Common.Task_Info.Bound_To_LWP then
1013            Opts := Opts + THR_BOUND;
1014         end if;
1015
1016      else
1017         Opts := THR_DETACHED + THR_BOUND;
1018      end if;
1019
1020      --  Note: the use of Unrestricted_Access in the following call is needed
1021      --  because otherwise we have an error of getting a access-to-volatile
1022      --  value which points to a non-volatile object. But in this case it is
1023      --  safe to do this, since we know we have no problems with aliasing and
1024      --  Unrestricted_Access bypasses this check.
1025
1026      Result :=
1027        thr_create
1028          (System.Null_Address,
1029           Adjusted_Stack_Size,
1030           Thread_Body_Access (Wrapper),
1031           To_Address (T),
1032           Opts,
1033           T.Common.LL.Thread'Unrestricted_Access);
1034
1035      Succeeded := Result = 0;
1036      pragma Assert
1037        (Result = 0
1038          or else Result = ENOMEM
1039          or else Result = EAGAIN);
1040   end Create_Task;
1041
1042   ------------------
1043   -- Finalize_TCB --
1044   ------------------
1045
1046   procedure Finalize_TCB (T : Task_Id) is
1047      Result : Interfaces.C.int;
1048
1049   begin
1050      T.Common.LL.Thread := Null_Thread_Id;
1051
1052      if not Single_Lock then
1053         Result := mutex_destroy (T.Common.LL.L.L'Access);
1054         pragma Assert (Result = 0);
1055      end if;
1056
1057      Result := cond_destroy (T.Common.LL.CV'Access);
1058      pragma Assert (Result = 0);
1059
1060      if T.Known_Tasks_Index /= -1 then
1061         Known_Tasks (T.Known_Tasks_Index) := null;
1062      end if;
1063
1064      ATCB_Allocation.Free_ATCB (T);
1065   end Finalize_TCB;
1066
1067   ---------------
1068   -- Exit_Task --
1069   ---------------
1070
1071   --  This procedure must be called with abort deferred. It can no longer
1072   --  call Self or access the current task's ATCB, since the ATCB has been
1073   --  deallocated.
1074
1075   procedure Exit_Task is
1076   begin
1077      Specific.Set (null);
1078   end Exit_Task;
1079
1080   ----------------
1081   -- Abort_Task --
1082   ----------------
1083
1084   procedure Abort_Task (T : Task_Id) is
1085      Result : Interfaces.C.int;
1086   begin
1087      if Abort_Handler_Installed then
1088         pragma Assert (T /= Self);
1089         Result :=
1090           thr_kill
1091             (T.Common.LL.Thread,
1092              Signal (System.Interrupt_Management.Abort_Task_Interrupt));
1093         pragma Assert (Result = 0);
1094      end if;
1095   end Abort_Task;
1096
1097   -----------
1098   -- Sleep --
1099   -----------
1100
1101   procedure Sleep
1102     (Self_ID : Task_Id;
1103      Reason  : Task_States)
1104   is
1105      Result : Interfaces.C.int;
1106
1107   begin
1108      pragma Assert (Check_Sleep (Reason));
1109
1110      if Single_Lock then
1111         Result :=
1112           cond_wait
1113             (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
1114      else
1115         Result :=
1116           cond_wait
1117             (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
1118      end if;
1119
1120      pragma Assert
1121        (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
1122      pragma Assert (Result = 0 or else Result = EINTR);
1123   end Sleep;
1124
1125   --  Note that we are relying heavily here on GNAT representing
1126   --  Calendar.Time, System.Real_Time.Time, Duration,
1127   --  System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of
1128   --  nanoseconds.
1129
1130   --  This allows us to always pass the timeout value as a Duration
1131
1132   --  ???
1133   --  We are taking liberties here with the semantics of the delays. That is,
1134   --  we make no distinction between delays on the Calendar clock and delays
1135   --  on the Real_Time clock. That is technically incorrect, if the Calendar
1136   --  clock happens to be reset or adjusted. To solve this defect will require
1137   --  modification to the compiler interface, so that it can pass through more
1138   --  information, to tell us here which clock to use.
1139
1140   --  cond_timedwait will return if any of the following happens:
1141   --  1) some other task did cond_signal on this condition variable
1142   --     In this case, the return value is 0
1143   --  2) the call just returned, for no good reason
1144   --     This is called a "spurious wakeup".
1145   --     In this case, the return value may also be 0.
1146   --  3) the time delay expires
1147   --     In this case, the return value is ETIME
1148   --  4) this task received a signal, which was handled by some
1149   --     handler procedure, and now the thread is resuming execution
1150   --     UNIX calls this an "interrupted" system call.
1151   --     In this case, the return value is EINTR
1152
1153   --  If the cond_timedwait returns 0 or EINTR, it is still possible that the
1154   --  time has actually expired, and by chance a signal or cond_signal
1155   --  occurred at around the same time.
1156
1157   --  We have also observed that on some OS's the value ETIME will be
1158   --  returned, but the clock will show that the full delay has not yet
1159   --  expired.
1160
1161   --  For these reasons, we need to check the clock after return from
1162   --  cond_timedwait. If the time has expired, we will set Timedout = True.
1163
1164   --  This check might be omitted for systems on which the cond_timedwait()
1165   --  never returns early or wakes up spuriously.
1166
1167   --  Annex D requires that completion of a delay cause the task to go to the
1168   --  end of its priority queue, regardless of whether the task actually was
1169   --  suspended by the delay. Since cond_timedwait does not do this on
1170   --  Solaris, we add a call to thr_yield at the end. We might do this at the
1171   --  beginning, instead, but then the round-robin effect would not be the
1172   --  same; the delayed task would be ahead of other tasks of the same
1173   --  priority that awoke while it was sleeping.
1174
1175   --  For Timed_Sleep, we are expecting possible cond_signals to indicate
1176   --  other events (e.g., completion of a RV or completion of the abortable
1177   --  part of an async. select), we want to always return if interrupted. The
1178   --  caller will be responsible for checking the task state to see whether
1179   --  the wakeup was spurious, and to go back to sleep again in that case. We
1180   --  don't need to check for pending abort or priority change on the way in
1181   --  our out; that is the caller's responsibility.
1182
1183   --  For Timed_Delay, we are not expecting any cond_signals or other
1184   --  interruptions, except for priority changes and aborts. Therefore, we
1185   --  don't want to return unless the delay has actually expired, or the call
1186   --  has been aborted. In this case, since we want to implement the entire
1187   --  delay statement semantics, we do need to check for pending abort and
1188   --  priority changes. We can quietly handle priority changes inside the
1189   --  procedure, since there is no entry-queue reordering involved.
1190
1191   -----------------
1192   -- Timed_Sleep --
1193   -----------------
1194
1195   procedure Timed_Sleep
1196     (Self_ID  : Task_Id;
1197      Time     : Duration;
1198      Mode     : ST.Delay_Modes;
1199      Reason   : System.Tasking.Task_States;
1200      Timedout : out Boolean;
1201      Yielded  : out Boolean)
1202   is
1203      Base_Time  : constant Duration := Monotonic_Clock;
1204      Check_Time : Duration := Base_Time;
1205      Abs_Time   : Duration;
1206      Request    : aliased timespec;
1207      Result     : Interfaces.C.int;
1208
1209   begin
1210      pragma Assert (Check_Sleep (Reason));
1211      Timedout := True;
1212      Yielded := False;
1213
1214      Abs_Time :=
1215        (if Mode = Relative
1216         then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
1217         else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
1218
1219      if Abs_Time > Check_Time then
1220         Request := To_Timespec (Abs_Time);
1221         loop
1222            exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
1223
1224            if Single_Lock then
1225               Result :=
1226                 cond_timedwait
1227                   (Self_ID.Common.LL.CV'Access,
1228                    Single_RTS_Lock.L'Access, Request'Access);
1229            else
1230               Result :=
1231                 cond_timedwait
1232                   (Self_ID.Common.LL.CV'Access,
1233                    Self_ID.Common.LL.L.L'Access, Request'Access);
1234            end if;
1235
1236            Yielded := True;
1237
1238            Check_Time := Monotonic_Clock;
1239            exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
1240
1241            if Result = 0 or Result = EINTR then
1242
1243               --  Somebody may have called Wakeup for us
1244
1245               Timedout := False;
1246               exit;
1247            end if;
1248
1249            pragma Assert (Result = ETIME);
1250         end loop;
1251      end if;
1252
1253      pragma Assert
1254        (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
1255   end Timed_Sleep;
1256
1257   -----------------
1258   -- Timed_Delay --
1259   -----------------
1260
1261   procedure Timed_Delay
1262     (Self_ID : Task_Id;
1263      Time    : Duration;
1264      Mode    : ST.Delay_Modes)
1265   is
1266      Base_Time  : constant Duration := Monotonic_Clock;
1267      Check_Time : Duration := Base_Time;
1268      Abs_Time   : Duration;
1269      Request    : aliased timespec;
1270      Result     : Interfaces.C.int;
1271      Yielded    : Boolean := False;
1272
1273   begin
1274      if Single_Lock then
1275         Lock_RTS;
1276      end if;
1277
1278      Write_Lock (Self_ID);
1279
1280      Abs_Time :=
1281        (if Mode = Relative
1282         then Time + Check_Time
1283         else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
1284
1285      if Abs_Time > Check_Time then
1286         Request := To_Timespec (Abs_Time);
1287         Self_ID.Common.State := Delay_Sleep;
1288
1289         pragma Assert (Check_Sleep (Delay_Sleep));
1290
1291         loop
1292            exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
1293
1294            if Single_Lock then
1295               Result :=
1296                 cond_timedwait
1297                   (Self_ID.Common.LL.CV'Access,
1298                    Single_RTS_Lock.L'Access,
1299                    Request'Access);
1300            else
1301               Result :=
1302                 cond_timedwait
1303                   (Self_ID.Common.LL.CV'Access,
1304                    Self_ID.Common.LL.L.L'Access,
1305                    Request'Access);
1306            end if;
1307
1308            Yielded := True;
1309
1310            Check_Time := Monotonic_Clock;
1311            exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
1312
1313            pragma Assert
1314              (Result = 0     or else
1315               Result = ETIME or else
1316               Result = EINTR);
1317         end loop;
1318
1319         pragma Assert
1320           (Record_Wakeup
1321              (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
1322
1323         Self_ID.Common.State := Runnable;
1324      end if;
1325
1326      Unlock (Self_ID);
1327
1328      if Single_Lock then
1329         Unlock_RTS;
1330      end if;
1331
1332      if not Yielded then
1333         thr_yield;
1334      end if;
1335   end Timed_Delay;
1336
1337   ------------
1338   -- Wakeup --
1339   ------------
1340
1341   procedure Wakeup
1342     (T : Task_Id;
1343      Reason : Task_States)
1344   is
1345      Result : Interfaces.C.int;
1346   begin
1347      pragma Assert (Check_Wakeup (T, Reason));
1348      Result := cond_signal (T.Common.LL.CV'Access);
1349      pragma Assert (Result = 0);
1350   end Wakeup;
1351
1352   ---------------------------
1353   -- Check_Initialize_Lock --
1354   ---------------------------
1355
1356   --  The following code is intended to check some of the invariant assertions
1357   --  related to lock usage, on which we depend.
1358
1359   function Check_Initialize_Lock
1360     (L     : Lock_Ptr;
1361      Level : Lock_Level) return Boolean
1362   is
1363      Self_ID : constant Task_Id := Self;
1364
1365   begin
1366      --  Check that caller is abort-deferred
1367
1368      if Self_ID.Deferral_Level = 0 then
1369         return False;
1370      end if;
1371
1372      --  Check that the lock is not yet initialized
1373
1374      if L.Level /= 0 then
1375         return False;
1376      end if;
1377
1378      L.Level := Lock_Level'Pos (Level) + 1;
1379      return True;
1380   end Check_Initialize_Lock;
1381
1382   ----------------
1383   -- Check_Lock --
1384   ----------------
1385
1386   function Check_Lock (L : Lock_Ptr) return Boolean is
1387      Self_ID : constant Task_Id := Self;
1388      P       : Lock_Ptr;
1389
1390   begin
1391      --  Check that the argument is not null
1392
1393      if L = null then
1394         return False;
1395      end if;
1396
1397      --  Check that L is not frozen
1398
1399      if L.Frozen then
1400         return False;
1401      end if;
1402
1403      --  Check that caller is abort-deferred
1404
1405      if Self_ID.Deferral_Level = 0 then
1406         return False;
1407      end if;
1408
1409      --  Check that caller is not holding this lock already
1410
1411      if L.Owner = To_Owner_ID (To_Address (Self_ID)) then
1412         return False;
1413      end if;
1414
1415      if Single_Lock then
1416         return True;
1417      end if;
1418
1419      --  Check that TCB lock order rules are satisfied
1420
1421      P := Self_ID.Common.LL.Locks;
1422      if P /= null then
1423         if P.Level >= L.Level
1424           and then (P.Level > 2 or else L.Level > 2)
1425         then
1426            return False;
1427         end if;
1428      end if;
1429
1430      return True;
1431   end Check_Lock;
1432
1433   -----------------
1434   -- Record_Lock --
1435   -----------------
1436
1437   function Record_Lock (L : Lock_Ptr) return Boolean is
1438      Self_ID : constant Task_Id := Self;
1439      P       : Lock_Ptr;
1440
1441   begin
1442      Lock_Count := Lock_Count + 1;
1443
1444      --  There should be no owner for this lock at this point
1445
1446      if L.Owner /= null then
1447         return False;
1448      end if;
1449
1450      --  Record new owner
1451
1452      L.Owner := To_Owner_ID (To_Address (Self_ID));
1453
1454      if Single_Lock then
1455         return True;
1456      end if;
1457
1458      --  Check that TCB lock order rules are satisfied
1459
1460      P := Self_ID.Common.LL.Locks;
1461
1462      if P /= null then
1463         L.Next := P;
1464      end if;
1465
1466      Self_ID.Common.LL.Locking := null;
1467      Self_ID.Common.LL.Locks := L;
1468      return True;
1469   end Record_Lock;
1470
1471   -----------------
1472   -- Check_Sleep --
1473   -----------------
1474
1475   function Check_Sleep (Reason : Task_States) return Boolean is
1476      pragma Unreferenced (Reason);
1477
1478      Self_ID : constant Task_Id := Self;
1479      P       : Lock_Ptr;
1480
1481   begin
1482      --  Check that caller is abort-deferred
1483
1484      if Self_ID.Deferral_Level = 0 then
1485         return False;
1486      end if;
1487
1488      if Single_Lock then
1489         return True;
1490      end if;
1491
1492      --  Check that caller is holding own lock, on top of list
1493
1494      if Self_ID.Common.LL.Locks /=
1495        To_Lock_Ptr (Self_ID.Common.LL.L'Access)
1496      then
1497         return False;
1498      end if;
1499
1500      --  Check that TCB lock order rules are satisfied
1501
1502      if Self_ID.Common.LL.Locks.Next /= null then
1503         return False;
1504      end if;
1505
1506      Self_ID.Common.LL.L.Owner := null;
1507      P := Self_ID.Common.LL.Locks;
1508      Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
1509      P.Next := null;
1510      return True;
1511   end Check_Sleep;
1512
1513   -------------------
1514   -- Record_Wakeup --
1515   -------------------
1516
1517   function Record_Wakeup
1518     (L      : Lock_Ptr;
1519      Reason : Task_States) return Boolean
1520   is
1521      pragma Unreferenced (Reason);
1522
1523      Self_ID : constant Task_Id := Self;
1524      P       : Lock_Ptr;
1525
1526   begin
1527      --  Record new owner
1528
1529      L.Owner := To_Owner_ID (To_Address (Self_ID));
1530
1531      if Single_Lock then
1532         return True;
1533      end if;
1534
1535      --  Check that TCB lock order rules are satisfied
1536
1537      P := Self_ID.Common.LL.Locks;
1538
1539      if P /= null then
1540         L.Next := P;
1541      end if;
1542
1543      Self_ID.Common.LL.Locking := null;
1544      Self_ID.Common.LL.Locks := L;
1545      return True;
1546   end Record_Wakeup;
1547
1548   ------------------
1549   -- Check_Wakeup --
1550   ------------------
1551
1552   function Check_Wakeup
1553     (T      : Task_Id;
1554      Reason : Task_States) return Boolean
1555   is
1556      Self_ID : constant Task_Id := Self;
1557
1558   begin
1559      --  Is caller holding T's lock?
1560
1561      if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then
1562         return False;
1563      end if;
1564
1565      --  Are reasons for wakeup and sleep consistent?
1566
1567      if T.Common.State /= Reason then
1568         return False;
1569      end if;
1570
1571      return True;
1572   end Check_Wakeup;
1573
1574   ------------------
1575   -- Check_Unlock --
1576   ------------------
1577
1578   function Check_Unlock (L : Lock_Ptr) return Boolean is
1579      Self_ID : constant Task_Id := Self;
1580      P       : Lock_Ptr;
1581
1582   begin
1583      Unlock_Count := Unlock_Count + 1;
1584
1585      if L = null then
1586         return False;
1587      end if;
1588
1589      if L.Buddy /= null then
1590         return False;
1591      end if;
1592
1593      --  Magic constant 4???
1594
1595      if L.Level = 4 then
1596         Check_Count := Unlock_Count;
1597      end if;
1598
1599      --  Magic constant 1000???
1600
1601      if Unlock_Count - Check_Count > 1000 then
1602         Check_Count := Unlock_Count;
1603      end if;
1604
1605      --  Check that caller is abort-deferred
1606
1607      if Self_ID.Deferral_Level = 0 then
1608         return False;
1609      end if;
1610
1611      --  Check that caller is holding this lock, on top of list
1612
1613      if Self_ID.Common.LL.Locks /= L then
1614         return False;
1615      end if;
1616
1617      --  Record there is no owner now
1618
1619      L.Owner := null;
1620      P := Self_ID.Common.LL.Locks;
1621      Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
1622      P.Next := null;
1623      return True;
1624   end Check_Unlock;
1625
1626   -------------------------
1627   -- Check_Finalize_Lock --
1628   -------------------------
1629
1630   function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
1631      Self_ID : constant Task_Id := Self;
1632
1633   begin
1634      --  Check that caller is abort-deferred
1635
1636      if Self_ID.Deferral_Level = 0 then
1637         return False;
1638      end if;
1639
1640      --  Check that no one is holding this lock
1641
1642      if L.Owner /= null then
1643         return False;
1644      end if;
1645
1646      L.Frozen := True;
1647      return True;
1648   end Check_Finalize_Lock;
1649
1650   ----------------
1651   -- Initialize --
1652   ----------------
1653
1654   procedure Initialize (S : in out Suspension_Object) is
1655      Result : Interfaces.C.int;
1656
1657   begin
1658      --  Initialize internal state (always to zero (RM D.10(6)))
1659
1660      S.State := False;
1661      S.Waiting := False;
1662
1663      --  Initialize internal mutex
1664
1665      Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address);
1666      pragma Assert (Result = 0 or else Result = ENOMEM);
1667
1668      if Result = ENOMEM then
1669         raise Storage_Error with "Failed to allocate a lock";
1670      end if;
1671
1672      --  Initialize internal condition variable
1673
1674      Result := cond_init (S.CV'Access, USYNC_THREAD, 0);
1675      pragma Assert (Result = 0 or else Result = ENOMEM);
1676
1677      if Result /= 0 then
1678         Result := mutex_destroy (S.L'Access);
1679         pragma Assert (Result = 0);
1680
1681         if Result = ENOMEM then
1682            raise Storage_Error;
1683         end if;
1684      end if;
1685   end Initialize;
1686
1687   --------------
1688   -- Finalize --
1689   --------------
1690
1691   procedure Finalize (S : in out Suspension_Object) is
1692      Result  : Interfaces.C.int;
1693
1694   begin
1695      --  Destroy internal mutex
1696
1697      Result := mutex_destroy (S.L'Access);
1698      pragma Assert (Result = 0);
1699
1700      --  Destroy internal condition variable
1701
1702      Result := cond_destroy (S.CV'Access);
1703      pragma Assert (Result = 0);
1704   end Finalize;
1705
1706   -------------------
1707   -- Current_State --
1708   -------------------
1709
1710   function Current_State (S : Suspension_Object) return Boolean is
1711   begin
1712      --  We do not want to use lock on this read operation. State is marked
1713      --  as Atomic so that we ensure that the value retrieved is correct.
1714
1715      return S.State;
1716   end Current_State;
1717
1718   ---------------
1719   -- Set_False --
1720   ---------------
1721
1722   procedure Set_False (S : in out Suspension_Object) is
1723      Result  : Interfaces.C.int;
1724
1725   begin
1726      SSL.Abort_Defer.all;
1727
1728      Result := mutex_lock (S.L'Access);
1729      pragma Assert (Result = 0);
1730
1731      S.State := False;
1732
1733      Result := mutex_unlock (S.L'Access);
1734      pragma Assert (Result = 0);
1735
1736      SSL.Abort_Undefer.all;
1737   end Set_False;
1738
1739   --------------
1740   -- Set_True --
1741   --------------
1742
1743   procedure Set_True (S : in out Suspension_Object) is
1744      Result : Interfaces.C.int;
1745
1746   begin
1747      SSL.Abort_Defer.all;
1748
1749      Result := mutex_lock (S.L'Access);
1750      pragma Assert (Result = 0);
1751
1752      --  If there is already a task waiting on this suspension object then
1753      --  we resume it, leaving the state of the suspension object to False,
1754      --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1755      --  the state to True.
1756
1757      if S.Waiting then
1758         S.Waiting := False;
1759         S.State := False;
1760
1761         Result := cond_signal (S.CV'Access);
1762         pragma Assert (Result = 0);
1763
1764      else
1765         S.State := True;
1766      end if;
1767
1768      Result := mutex_unlock (S.L'Access);
1769      pragma Assert (Result = 0);
1770
1771      SSL.Abort_Undefer.all;
1772   end Set_True;
1773
1774   ------------------------
1775   -- Suspend_Until_True --
1776   ------------------------
1777
1778   procedure Suspend_Until_True (S : in out Suspension_Object) is
1779      Result : Interfaces.C.int;
1780
1781   begin
1782      SSL.Abort_Defer.all;
1783
1784      Result := mutex_lock (S.L'Access);
1785      pragma Assert (Result = 0);
1786
1787      if S.Waiting then
1788
1789         --  Program_Error must be raised upon calling Suspend_Until_True
1790         --  if another task is already waiting on that suspension object
1791         --  (RM D.10(10)).
1792
1793         Result := mutex_unlock (S.L'Access);
1794         pragma Assert (Result = 0);
1795
1796         SSL.Abort_Undefer.all;
1797
1798         raise Program_Error;
1799
1800      else
1801         --  Suspend the task if the state is False. Otherwise, the task
1802         --  continues its execution, and the state of the suspension object
1803         --  is set to False (ARM D.10 par. 9).
1804
1805         if S.State then
1806            S.State := False;
1807         else
1808            S.Waiting := True;
1809
1810            loop
1811               --  Loop in case pthread_cond_wait returns earlier than expected
1812               --  (e.g. in case of EINTR caused by a signal).
1813
1814               Result := cond_wait (S.CV'Access, S.L'Access);
1815               pragma Assert (Result = 0 or else Result = EINTR);
1816
1817               exit when not S.Waiting;
1818            end loop;
1819         end if;
1820
1821         Result := mutex_unlock (S.L'Access);
1822         pragma Assert (Result = 0);
1823
1824         SSL.Abort_Undefer.all;
1825      end if;
1826   end Suspend_Until_True;
1827
1828   ----------------
1829   -- Check_Exit --
1830   ----------------
1831
1832   function Check_Exit (Self_ID : Task_Id) return Boolean is
1833   begin
1834      --  Check that caller is just holding Global_Task_Lock and no other locks
1835
1836      if Self_ID.Common.LL.Locks = null then
1837         return False;
1838      end if;
1839
1840      --  2 = Global_Task_Level
1841
1842      if Self_ID.Common.LL.Locks.Level /= 2 then
1843         return False;
1844      end if;
1845
1846      if Self_ID.Common.LL.Locks.Next /= null then
1847         return False;
1848      end if;
1849
1850      --  Check that caller is abort-deferred
1851
1852      if Self_ID.Deferral_Level = 0 then
1853         return False;
1854      end if;
1855
1856      return True;
1857   end Check_Exit;
1858
1859   --------------------
1860   -- Check_No_Locks --
1861   --------------------
1862
1863   function Check_No_Locks (Self_ID : Task_Id) return Boolean is
1864   begin
1865      return Self_ID.Common.LL.Locks = null;
1866   end Check_No_Locks;
1867
1868   ----------------------
1869   -- Environment_Task --
1870   ----------------------
1871
1872   function Environment_Task return Task_Id is
1873   begin
1874      return Environment_Task_Id;
1875   end Environment_Task;
1876
1877   --------------
1878   -- Lock_RTS --
1879   --------------
1880
1881   procedure Lock_RTS is
1882   begin
1883      Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1884   end Lock_RTS;
1885
1886   ----------------
1887   -- Unlock_RTS --
1888   ----------------
1889
1890   procedure Unlock_RTS is
1891   begin
1892      Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1893   end Unlock_RTS;
1894
1895   ------------------
1896   -- Suspend_Task --
1897   ------------------
1898
1899   function Suspend_Task
1900     (T           : ST.Task_Id;
1901      Thread_Self : Thread_Id) return Boolean
1902   is
1903   begin
1904      if T.Common.LL.Thread /= Thread_Self then
1905         return thr_suspend (T.Common.LL.Thread) = 0;
1906      else
1907         return True;
1908      end if;
1909   end Suspend_Task;
1910
1911   -----------------
1912   -- Resume_Task --
1913   -----------------
1914
1915   function Resume_Task
1916     (T           : ST.Task_Id;
1917      Thread_Self : Thread_Id) return Boolean
1918   is
1919   begin
1920      if T.Common.LL.Thread /= Thread_Self then
1921         return thr_continue (T.Common.LL.Thread) = 0;
1922      else
1923         return True;
1924      end if;
1925   end Resume_Task;
1926
1927   --------------------
1928   -- Stop_All_Tasks --
1929   --------------------
1930
1931   procedure Stop_All_Tasks is
1932   begin
1933      null;
1934   end Stop_All_Tasks;
1935
1936   ---------------
1937   -- Stop_Task --
1938   ---------------
1939
1940   function Stop_Task (T : ST.Task_Id) return Boolean is
1941      pragma Unreferenced (T);
1942   begin
1943      return False;
1944   end Stop_Task;
1945
1946   -------------------
1947   -- Continue_Task --
1948   -------------------
1949
1950   function Continue_Task (T : ST.Task_Id) return Boolean is
1951      pragma Unreferenced (T);
1952   begin
1953      return False;
1954   end Continue_Task;
1955
1956   -----------------------
1957   -- Set_Task_Affinity --
1958   -----------------------
1959
1960   procedure Set_Task_Affinity (T : ST.Task_Id) is
1961      Result    : Interfaces.C.int;
1962      Proc      : processorid_t;  --  User processor #
1963      Last_Proc : processorid_t;  --  Last processor #
1964
1965      use System.Task_Info;
1966      use type System.Multiprocessors.CPU_Range;
1967
1968   begin
1969      --  Do nothing if the underlying thread has not yet been created. If the
1970      --  thread has not yet been created then the proper affinity will be set
1971      --  during its creation.
1972
1973      if T.Common.LL.Thread = Null_Thread_Id then
1974         null;
1975
1976      --  pragma CPU
1977
1978      elsif T.Common.Base_CPU /=
1979           System.Multiprocessors.Not_A_Specific_CPU
1980      then
1981         --  The CPU numbering in pragma CPU starts at 1 while the subprogram
1982         --  to set the affinity starts at 0, therefore we must substract 1.
1983
1984         Result :=
1985           processor_bind
1986             (P_LWPID, id_t (T.Common.LL.LWP),
1987              processorid_t (T.Common.Base_CPU) - 1, null);
1988         pragma Assert (Result = 0);
1989
1990      --  Task_Info
1991
1992      elsif T.Common.Task_Info /= null then
1993         if T.Common.Task_Info.New_LWP
1994           and then T.Common.Task_Info.CPU /= CPU_UNCHANGED
1995         then
1996            Last_Proc := Num_Procs - 1;
1997
1998            if T.Common.Task_Info.CPU = ANY_CPU then
1999               Result := 0;
2000
2001               Proc := 0;
2002               while Proc < Last_Proc loop
2003                  Result := p_online (Proc, PR_STATUS);
2004                  exit when Result = PR_ONLINE;
2005                  Proc := Proc + 1;
2006               end loop;
2007
2008               Result :=
2009                 processor_bind
2010                   (P_LWPID, id_t (T.Common.LL.LWP), Proc, null);
2011               pragma Assert (Result = 0);
2012
2013            else
2014               --  Use specified processor
2015
2016               if T.Common.Task_Info.CPU < 0
2017                 or else T.Common.Task_Info.CPU > Last_Proc
2018               then
2019                  raise Invalid_CPU_Number;
2020               end if;
2021
2022               Result :=
2023                 processor_bind
2024                   (P_LWPID, id_t (T.Common.LL.LWP),
2025                    T.Common.Task_Info.CPU, null);
2026               pragma Assert (Result = 0);
2027            end if;
2028         end if;
2029
2030      --  Handle dispatching domains
2031
2032      elsif T.Common.Domain /= null
2033        and then (T.Common.Domain /= ST.System_Domain
2034                   or else T.Common.Domain.all /=
2035                             (Multiprocessors.CPU'First ..
2036                              Multiprocessors.Number_Of_CPUs => True))
2037      then
2038         declare
2039            CPU_Set : aliased psetid_t;
2040            Result  : int;
2041
2042         begin
2043            Result := pset_create (CPU_Set'Access);
2044            pragma Assert (Result = 0);
2045
2046            --  Set the affinity to all the processors belonging to the
2047            --  dispatching domain.
2048
2049            for Proc in T.Common.Domain'Range loop
2050
2051               --  The Ada CPU numbering starts at 1 while the subprogram to
2052               --  set the affinity starts at 0, therefore we must substract 1.
2053
2054               if T.Common.Domain (Proc) then
2055                  Result :=
2056                    pset_assign (CPU_Set, processorid_t (Proc) - 1, null);
2057                  pragma Assert (Result = 0);
2058               end if;
2059            end loop;
2060
2061            Result :=
2062              pset_bind (CPU_Set, P_LWPID, id_t (T.Common.LL.LWP), null);
2063            pragma Assert (Result = 0);
2064         end;
2065      end if;
2066   end Set_Task_Affinity;
2067
2068end System.Task_Primitives.Operations;
2069