1 ------------------------------------------------------------------------------
3 -- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K _ P R I M I T I V E S --
11 -- Copyright (C) 1991,1992,1993,1994,1996 Florida State University --
13 -- GNARL is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU Library General Public License as published by the --
15 -- Free Software Foundation; either version 2, or (at your option) any --
16 -- later version. GNARL is distributed in the hope that it will be use- --
17 -- ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
18 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- --
19 -- eral Library Public License for more details. You should have received --
20 -- a copy of the GNU Library General Public License along with GNARL; see --
21 -- file COPYING.LIB. If not, write to the Free Software Foundation, 675 --
22 -- Mass Ave, Cambridge, MA 02139, USA. --
24 ------------------------------------------------------------------------------
27 with Interfaces.C.POSIX_timers;
29 with Interfaces.C.POSIX_Error;
30 use Interfaces.C.POSIX_Error;
32 with Interfaces.C.POSIX_RTE;
33 use Interfaces.C.POSIX_RTE;
35 with Interfaces.C.Pthreads;
36 use Interfaces.C.Pthreads;
44 with System.Storage_Elements;
45 use System.Storage_Elements;
47 with System.Compiler_Exceptions;
48 use System.Compiler_Exceptions;
50 with System.Task_Specific_Data;
51 use System.Task_Specific_Data;
53 with System.Secondary_Stack;
54 use System.Secondary_Stack;
56 with System.Tasking_Soft_Links;
58 with System.Task_Clock;
59 use System.Task_Clock;
61 with Unchecked_Conversion;
62 with Interfaces.C.System_Constants;
64 package body System.Task_Primitives is
66 use Interfaces.C.Pthreads;
67 use Interfaces.C.System_Constants;
69 package RTE renames Interfaces.C.POSIX_RTE;
70 package TSL renames System.Tasking_Soft_Links;
72 Test_And_Set_Mutex : Lock;
74 Abort_Signal : constant := 6;
76 Abort_Handler : Abort_Handler_Pointer;
78 ATCB_Key : aliased pthread_key_t;
80 Unblocked_Signal_Mask : aliased RTE.Signal_Set;
81 -- The set of signals that should be unblocked in a task.
82 -- This is in general the signals that can be generated synchronously,
83 -- and which should therefore be converted into Ada exceptions.
84 -- It also includes the Abort_Signal, to allow asynchronous abortion.
86 function To_void_ptr is new
87 Unchecked_Conversion (TCB_Ptr, void_ptr);
89 function To_TCB_Ptr is new
90 Unchecked_Conversion (void_ptr, TCB_Ptr);
92 function pthread_mutexattr_setprotocol
93 (attr : access pthread_attr_t; priority : integer) return int;
95 pthread_mutexattr_setprotocol,
96 "pthread_mutexattr_setprotocol",
97 "pthread_mutexattr_setprotocol");
99 function pthread_mutexattr_setprio_ceiling
100 (attr : access pthread_attr_t; priority : int) return int;
102 pthread_mutexattr_setprio_ceiling,
103 "pthread_mutexattr_setprio_ceiling",
104 "pthread_mutexattr_setprio_ceiling");
106 pthread_mutexattr_default : pthread_mutexattr_t;
107 pragma Import (C, pthread_mutexattr_default,
108 "pthread_mutexattr_default",
109 "pthread_mutexattr_default");
111 -----------------------
112 -- Local Subprograms --
113 -----------------------
115 procedure Abort_Wrapper
117 info : RTE.siginfo_ptr;
118 context : System.Address);
119 -- This is a signal handler procedure which calls the user-specified
120 -- abort handler procedure.
122 procedure LL_Wrapper (T : TCB_Ptr);
123 -- A wrapper procedure that is called from a new low-level task.
124 -- It performs initializations for the new task and calls the
125 -- user-specified startup procedure.
127 -------------------------
128 -- Initialize_LL_Tasks --
129 -------------------------
131 procedure Initialize_LL_Tasks (T : TCB_Ptr) is
134 T.LL_Entry_Point := null;
135 T.Thread := pthread_self;
137 Result := pthread_key_create (ATCB_Key'Access, null);
139 if Result = FUNC_ERR then
140 raise Storage_Error; -- Insufficient resources.
143 T.Thread := pthread_self;
145 Result := pthread_setspecific (ATCB_Key, To_void_ptr (T));
147 if Result = FUNC_ERR then
148 GNAT.IO.Put_Line ("Get specific failed");
149 raise Storage_Error; -- Insufficient resources.
151 pragma Assert (Result /= FUNC_ERR,
152 "GNULLI failure---pthread_setspecific");
154 end Initialize_LL_Tasks;
160 function Self return TCB_Ptr is
161 Temp : aliased void_ptr;
164 Result := pthread_getspecific (ATCB_Key, Temp'Access);
165 pragma Assert (Result /= FUNC_ERR,
166 "GNULLI failure---pthread_getspecific");
167 return To_TCB_Ptr (Temp);
170 ---------------------
171 -- Initialize_Lock --
172 ---------------------
174 procedure Initialize_Lock
175 (Prio : System.Any_Priority;
179 Attributes : aliased pthread_mutexattr_t;
181 MUTEX_NONRECURSIVE_NP : constant := 2;
184 Result := pthread_mutexattr_init (Attributes'Access);
185 if Result = FUNC_ERR then
186 raise STORAGE_ERROR; -- should be ENOMEM
189 Result := pthread_mutexattr_setkind
190 (Attributes'Access, MUTEX_NONRECURSIVE_NP);
191 if Result = FUNC_ERR then
192 raise STORAGE_ERROR; -- should be ENOMEM
195 Result := pthread_mutex_init (L.mutex'Access, Attributes);
197 if Result = FUNC_ERR then
198 Result := pthread_mutexattr_destroy (Attributes'Access);
199 raise STORAGE_ERROR; -- should be ENOMEM ???
202 Result := pthread_mutexattr_destroy (Attributes'Access);
210 procedure Finalize_Lock (L : in out Lock) is
213 Result := pthread_mutex_destroy (L.mutex'Access);
215 (Result /= FUNC_ERR, "GNULLI failure---pthread_mutex_destroy");
223 -- The current pthreads implementation does not check for Ceiling
226 procedure Write_Lock (L : in out Lock; Ceiling_Violation : out Boolean) is
229 Ceiling_Violation := False;
230 Result := pthread_mutex_lock (L.mutex'Access);
232 (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_mutex_lock");
239 procedure Read_Lock (L : in out Lock; Ceiling_Violation : out Boolean)
246 procedure Unlock (L : in out Lock) is
249 Result := pthread_mutex_unlock (L.mutex'Access);
251 (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_mutex_unlock");
254 ---------------------
255 -- Initialize_Cond --
256 ---------------------
258 procedure Initialize_Cond (Cond : in out Condition_Variable) is
259 Attributes : aliased Pthreads.pthread_condattr_t;
262 Result := pthread_condattr_init (Attributes'Access);
264 if Result = FUNC_ERR then
265 raise STORAGE_ERROR; -- should be ENOMEM ???
268 -- Result := pthread_cond_init (Cond.CV'Access, Attributes'Access);
269 Result := pthread_cond_init (Cond.CV'Access, Attributes);
272 if Result = FUNC_ERR then
273 raise STORAGE_ERROR; -- should be ENOMEM ???
276 Result := pthread_condattr_destroy (Attributes'Access);
278 (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_condattr_destroy");
286 procedure Finalize_Cond (Cond : in out Condition_Variable) is
290 Result := pthread_cond_destroy (Cond.CV'Access);
292 (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_destroy");
300 procedure Cond_Wait (Cond : in out Condition_Variable; L : in out Lock) is
303 Result := pthread_cond_wait (Cond.CV'Access, L.mutex'Access);
305 (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_wait");
308 ---------------------
309 -- Cond_Timed_Wait --
310 ---------------------
312 procedure Cond_Timed_Wait
313 (Cond : in out Condition_Variable;
315 Abs_Time : System.Task_Clock.Stimespec;
316 Timed_Out : out Boolean) is
319 TV : aliased timespec;
324 Timed_Out := False; -- Assume success until we know otherwise
326 TV.tv_sec := int (Interfaces.C.POSIX_timers.time_t
327 (Task_Clock.Stimespec_Seconds (Abs_Time)));
329 TV.tv_nsec := long (Interfaces.C.POSIX_timers.Nanoseconds
330 (Task_Clock.Stimespec_NSeconds (Abs_Time)));
332 Result := pthread_cond_timedwait
333 (Cond.CV'Access, L.mutex'Access, TV'Access);
335 (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_timedwait");
343 procedure Cond_Signal (Cond : in out Condition_Variable) is
346 Result := pthread_cond_signal (Cond.CV'Access);
348 (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_signal");
355 procedure Set_Priority
357 Prio : System.Any_Priority) is
360 Thread : Pthreads.pthread_t renames T.Thread;
363 Result := pthread_setprio (Thread, int (Prio));
365 (Result /= FUNC_ERR, "GNULLI failure---pthread_setprio");
368 ----------------------
369 -- Set_Own_Priority --
370 ----------------------
372 procedure Set_Own_Priority (Prio : System.Any_Priority) is
376 -- pthread_setprio (pthread_self, int (Prio));
378 -- (Result /= FUNC_ERR, "GNULLI failure---pthread_setprio");
379 end Set_Own_Priority;
385 function Get_Priority (T : TCB_Ptr) return System.Any_Priority is
386 Priority : aliased int := 0;
388 -- ENOSYS Result := pthread_getprio (T.Thread, Priority'Access);
390 -- (Result /= FUNC_ERR, "GNULLI failure---pthread_getprio");
391 return System.Priority (Priority);
394 -----------------------
395 -- Get_Own_Priority --
396 -----------------------
398 function Get_Own_Priority return System.Any_Priority is
400 Priority : aliased int := 0;
402 Result := pthread_getprio (pthread_self, Priority'Access);
404 (Result /= FUNC_ERR, "GNULLI failure---pthread_getprio");
405 return System.Priority (Priority);
406 end Get_Own_Priority;
412 procedure Create_LL_Task
413 (Priority : System.Any_Priority;
414 Stack_Size : Task_Storage_Size;
415 Task_Info : System.Task_Info.Task_Info_Type;
416 LL_Entry_Point : LL_Task_Procedure_Access;
417 Arg : System.Address;
422 Attributes : aliased pthread_attr_t;
424 L_Priority : System.Any_Priority := Priority;
426 function To_Start_Addr is new
427 Unchecked_Conversion (System.Address, start_addr);
430 T.LL_Entry_Point := LL_Entry_Point;
432 T.Stack_Size := Stack_Size;
434 Result := pthread_attr_init (Attributes'Access);
435 pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_init");
437 -- Result := pthread_attr_setdetachstate (Attributes'Access, 1);
439 -- (Result /= FUNC_ERR, "GNULLI failure---pthread_setdetachstate");
441 Result := pthread_attr_setstacksize
442 (Attributes'Access, size_t (Stack_Size));
444 (Result /= FUNC_ERR, "GNULLI failure---pthread_setstacksize");
446 Result := pthread_attr_setinheritsched
447 (Attributes'Access, PTHREAD_DEFAULT_SCHED);
449 (Result /= FUNC_ERR, "GNULLI failure---pthread_setinheritsched");
451 Result := pthread_attr_setsched
452 (Attributes'Access, SCHED_FIFO);
454 (Result /= FUNC_ERR, "GNULLI failure---pthread_setinheritsched");
456 -- The following priority adjustment is a kludge to get around needing
457 -- root privileges to run at higher than 18 for FIFO or 19 for OTHER.
459 if (L_Priority > 18) then
461 elsif (L_Priority < 14) then
465 Result := pthread_attr_setprio
466 (Attributes'Access, int (L_Priority));
468 (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_setprio");
470 Result := pthread_create
473 To_Start_Addr (LL_Wrapper'Address),
475 if Result = FUNC_ERR then
476 GNAT.IO.Put_Line ("pthread create failed");
479 pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_create");
481 Result := pthread_attr_destroy (Attributes'Access);
483 (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_destroy");
491 procedure Exit_LL_Task is
493 pthread_exit (System.Null_Address);
500 procedure Abort_Task (T : TCB_Ptr) is
503 -- Result := pthread_kill (T.Thread);
505 -- (Result /= FUNC_ERR, "GNULLI failure---pthread_kill");
513 -- This procedure does nothing. It is intended for systems without
514 -- asynchronous abortion, where the runtime system would have to
515 -- synchronously poll for pending abortions. This should be done
516 -- at least at every synchronization point.
518 procedure Test_Abort is
523 ---------------------------
524 -- Install_Abort_Handler --
525 ---------------------------
527 procedure Install_Abort_Handler (Handler : Abort_Handler_Pointer) is
528 act : aliased RTE.struct_sigaction;
529 old_act : aliased RTE.struct_sigaction;
530 Result : POSIX_Error.Return_Code;
531 SA_SIGINFO : constant := 64;
533 use type POSIX_Error.Return_Code;
536 Abort_Handler := Handler;
538 act.sa_flags := SA_SIGINFO;
539 act.sa_handler := Abort_Wrapper'Address;
540 RTE.sigemptyset (act.sa_mask'Access, Result);
541 pragma Assert (Result /= FUNC_ERR, "GNULLI failure---sigemptyset");
543 RTE.sigaction (Abort_Signal, act'Access, old_act'Access, Result);
544 pragma Assert (Result /= FUNC_ERR, "GNULLI failure---sigaction");
545 end Install_Abort_Handler;
551 -- This is the handler called by the OS when an abort signal is
552 -- received; it in turn calls the handler installed by the client.
553 -- This procedure serves to isolate the client from the
554 -- implementation-specific calling conventions of asynchronous
557 procedure Abort_Wrapper
559 info : RTE.siginfo_ptr;
560 context : System.Address)
562 function Address_To_Call_State is new
563 Unchecked_Conversion (System.Address, Pre_Call_State);
566 Abort_Handler (Address_To_Call_State (context));
569 ---------------------------
570 -- Install_Error_Handler --
571 ---------------------------
573 procedure Install_Error_Handler (Handler : System.Address) is
580 -- Set up the soft links to tasking services used in the absence of
581 -- tasking. These replace tasking-free defaults.
583 Temp := TSL.Get_Jmpbuf_Address.all;
584 -- pthread_set_jumpbuf_address (Temp);
586 Temp := TSL.Get_Sec_Stack_Addr.all;
587 -- pthread_set_sec_stack_addr (Temp);
589 -- TSL.Get_Jmpbuf_Address := pthread_get_jumpbuf_address'Access;
590 -- TSL.Set_Jmpbuf_Address := pthread_set_jumpbuf_address'Access;
591 -- TSL.Get_Gnat_Exception := pthread_get_exception'Access;
592 -- TSL.Set_Gnat_Exception := pthread_set_exception'Access;
593 end Install_Error_Handler;
599 procedure LL_Assert (B : Boolean; M : String) is
608 procedure LL_Wrapper (T : TCB_Ptr) is
609 Result : POSIX_Error.Return_Code;
611 Exc_Stack : String (1 .. 256);
612 Exc_Base : Address := Exc_Stack (Exc_Stack'Last)'Address + 1;
613 Old_Set : aliased RTE.Signal_Set;
615 Result1 := pthread_setspecific (ATCB_Key, T.all'Address);
618 RTE.SIG_UNBLOCK, Unblocked_Signal_Mask'Access, Old_Set'Access, Result);
620 Result /= Failure, "GNULLI failure---sigprocmask");
622 -- Note that the following call may not return!
623 T.LL_Entry_Point (T.LL_Arg);
626 --------------------------
627 -- Test and Set support --
628 --------------------------
630 procedure Initialize_TAS_Cell (Cell : out TAS_Cell) is
633 end Initialize_TAS_Cell;
635 procedure Finalize_TAS_Cell (Cell : in out TAS_Cell) is
638 end Finalize_TAS_Cell;
640 procedure Clear (Cell : in out TAS_Cell) is
645 procedure Test_And_Set (Cell : in out TAS_Cell; Result : out Boolean) is
648 Write_Lock (Test_And_Set_Mutex, Error);
650 if Cell.Value = 1 then
656 Unlock (Test_And_Set_Mutex);
659 function Is_Set (Cell : in TAS_Cell) return Boolean is
661 return Cell.Value = 1;
664 Initialize_Lock (System.Any_Priority'Last, Test_And_Set_Mutex);
665 end System.Task_Primitives;