1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . O S _ I N T E R F A C E --
11 -- Copyright (C) 1997-2001 Free Software Foundation --
13 -- GNARL is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNARL; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNARL was developed by the GNARL team at Florida State University. It is --
32 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
33 -- State University (http://www.gnat.com). --
35 ------------------------------------------------------------------------------
37 -- This is the VxWorks version.
39 -- This package encapsulates all direct interfaces to OS services
40 -- that are needed by children of System.
43 -- Turn off polling, we do not want ATC polling to take place during
44 -- tasking operations. It causes infinite loops and other problems.
46 with Interfaces
.C
; use Interfaces
.C
;
49 -- used for Wind_TCB_Ptr
51 with Unchecked_Conversion
;
53 package body System
.OS_Interface
is
57 -- Option flags for taskSpawn
59 VX_UNBREAKABLE
: constant := 16#
0002#
;
60 VX_FP_TASK
: constant := 16#
0008#
;
61 VX_FP_PRIVATE_ENV
: constant := 16#
0080#
;
62 VX_NO_STACK_FILL
: constant := 16#
0100#
;
65 (name
: System
.Address
; -- Pointer to task name
69 start_routine
: Thread_Body
;
70 arg1
: System
.Address
;
79 arg10
: int
:= 0) return pthread_t
;
80 pragma Import
(C
, taskSpawn
, "taskSpawn");
82 procedure taskDelete
(tid
: pthread_t
);
83 pragma Import
(C
, taskDelete
, "taskDelete");
85 -- These are the POSIX scheduling priorities. These are enabled
86 -- when the global variable posixPriorityNumbering is 1.
88 POSIX_SCHED_FIFO_LOW_PRI
: constant := 0;
89 POSIX_SCHED_FIFO_HIGH_PRI
: constant := 255;
90 POSIX_SCHED_RR_LOW_PRI
: constant := 0;
91 POSIX_SCHED_RR_HIGH_PRI
: constant := 255;
93 -- These are the VxWorks native (default) scheduling priorities.
94 -- These are used when the global variable posixPriorityNumbering
97 SCHED_FIFO_LOW_PRI
: constant := 255;
98 SCHED_FIFO_HIGH_PRI
: constant := 0;
99 SCHED_RR_LOW_PRI
: constant := 255;
100 SCHED_RR_HIGH_PRI
: constant := 0;
102 -- Global variable to enable POSIX priority numbering.
103 -- By default, it is 0 and VxWorks native priority numbering
106 posixPriorityNumbering
: int
;
107 pragma Import
(C
, posixPriorityNumbering
, "posixPriorityNumbering");
109 -- VxWorks will let you set round-robin scheduling globally
110 -- for all tasks, but not for individual tasks. Attempting
111 -- to set the scheduling policy for a specific task (using
112 -- sched_setscheduler) to something other than what the system
113 -- is currently using will fail. If you wish to change the
114 -- scheduling policy, then use the following function to set
115 -- it globally for all tasks. When ticks is 0, time slicing
116 -- (round-robin scheduling) is disabled.
118 function kernelTimeSlice
(ticks
: int
) return int
;
119 pragma Import
(C
, kernelTimeSlice
, "kernelTimeSlice");
121 function taskPriorityGet
123 pPriority
: access int
)
125 pragma Import
(C
, taskPriorityGet
, "taskPriorityGet");
127 function taskPrioritySet
131 pragma Import
(C
, taskPrioritySet
, "taskPrioritySet");
133 function To_Wind_TCB_Ptr
is
134 new Unchecked_Conversion
(pthread_t
, Wind_TCB_Ptr
);
137 -- Error codes (errno). The lower level 16 bits are the
138 -- error code, with the upper 16 bits representing the
139 -- module number in which the error occurred. By convention,
140 -- the module number is 0 for UNIX errors. VxWorks reserves
141 -- module numbers 1-500, with the remaining module numbers
142 -- being available for user applications.
144 M_objLib
: constant := 61 * 2**16;
145 -- semTake() failure with ticks = NO_WAIT
146 S_objLib_OBJ_UNAVAILABLE
: constant := M_objLib
+ 2;
147 -- semTake() timeout with ticks > NO_WAIT
148 S_objLib_OBJ_TIMEOUT
: constant := M_objLib
+ 4;
150 -- We use two different kinds of VxWorks semaphores: mutex
151 -- and binary semaphores. A null (0) ID is returned when
152 -- a semaphore cannot be created. Binary semaphores and common
153 -- operations are declared in the spec of this package,
154 -- as they are used to implement hardware interrupt handling
157 (options
: int
) return SEM_ID
;
158 pragma Import
(C
, semMCreate
, "semMCreate");
161 function taskLock
return int
;
162 pragma Import
(C
, taskLock
, "taskLock");
164 function taskUnlock
return int
;
165 pragma Import
(C
, taskUnlock
, "taskUnlock");
167 -------------------------------------------------------
168 -- Convenience routines to convert between VxWorks --
169 -- priority and POSIX priority. --
170 -------------------------------------------------------
172 function To_Vxworks_Priority
(Priority
: in int
) return int
;
173 pragma Inline
(To_Vxworks_Priority
);
175 function To_Posix_Priority
(Priority
: in int
) return int
;
176 pragma Inline
(To_Posix_Priority
);
178 function To_Vxworks_Priority
(Priority
: in int
) return int
is
180 return SCHED_FIFO_LOW_PRI
- Priority
;
181 end To_Vxworks_Priority
;
183 function To_Posix_Priority
(Priority
: in int
) return int
is
185 return SCHED_FIFO_LOW_PRI
- Priority
;
186 end To_Posix_Priority
;
188 ----------------------------------------
189 -- Implementation of POSIX routines --
190 ----------------------------------------
192 -----------------------------------------
193 -- Nonstandard Thread Initialization --
194 -----------------------------------------
196 procedure pthread_init
is
202 ---------------------------
203 -- POSIX.1c Section 3 --
204 ---------------------------
207 (set
: access sigset_t
;
208 sig
: access Signal
) return int
210 Result
: Interfaces
.C
.int
;
213 (set
: access sigset_t
; sigvalue
: System
.Address
) return int
;
214 pragma Import
(C
, sigwaitinfo
, "sigwaitinfo");
217 Result
:= sigwaitinfo
(set
, System
.Null_Address
);
220 sig
.all := Signal
(Result
);
228 ----------------------------
229 -- POSIX.1c Section 11 --
230 ----------------------------
232 function pthread_mutexattr_init
233 (attr
: access pthread_mutexattr_t
) return int
is
235 -- Let's take advantage of VxWorks priority inversion
238 -- ??? - Do we want to also specify SEM_DELETE_SAFE???
240 attr
.Flags
:= int
(SEM_Q_PRIORITY
+ SEM_INVERSION_SAFE
);
242 -- Initialize the ceiling priority to the maximim priority.
243 -- We will use POSIX priorities since these routines are
244 -- emulating POSIX routines.
246 attr
.Prio_Ceiling
:= POSIX_SCHED_FIFO_HIGH_PRI
;
247 attr
.Protocol
:= PTHREAD_PRIO_INHERIT
;
249 end pthread_mutexattr_init
;
251 function pthread_mutexattr_destroy
252 (attr
: access pthread_mutexattr_t
) return int
is
255 attr
.Prio_Ceiling
:= POSIX_SCHED_FIFO_HIGH_PRI
;
256 attr
.Protocol
:= PTHREAD_PRIO_INHERIT
;
258 end pthread_mutexattr_destroy
;
260 function pthread_mutex_init
261 (mutex
: access pthread_mutex_t
;
262 attr
: access pthread_mutexattr_t
) return int
267 -- A mutex should initially be created full and the task
268 -- protected from deletion while holding the semaphore.
270 mutex
.Mutex
:= semMCreate
(attr
.Flags
);
271 mutex
.Prio_Ceiling
:= attr
.Prio_Ceiling
;
272 mutex
.Protocol
:= attr
.Protocol
;
274 if mutex
.Mutex
= 0 then
279 end pthread_mutex_init
;
281 function pthread_mutex_destroy
282 (mutex
: access pthread_mutex_t
) return int
286 Result
:= semDelete
(mutex
.Mutex
);
292 mutex
.Mutex
:= 0; -- Ensure the mutex is properly cleaned.
293 mutex
.Prio_Ceiling
:= POSIX_SCHED_FIFO_HIGH_PRI
;
294 mutex
.Protocol
:= PTHREAD_PRIO_INHERIT
;
296 end pthread_mutex_destroy
;
298 function pthread_mutex_lock
299 (mutex
: access pthread_mutex_t
) return int
302 WTCB_Ptr
: Wind_TCB_Ptr
;
304 WTCB_Ptr
:= To_Wind_TCB_Ptr
(taskIdSelf
);
306 if WTCB_Ptr
= null then
310 -- Check the current inherited priority in the WIND_TCB
311 -- against the mutex ceiling priority and return EINVAL
312 -- upon a ceiling violation.
314 -- We always convert the VxWorks priority to POSIX priority
315 -- in case the current priority ordering has changed (see
316 -- posixPriorityNumbering). The mutex ceiling priority is
317 -- maintained as POSIX compatible.
319 if mutex
.Protocol
= PTHREAD_PRIO_PROTECT
and then
320 To_Posix_Priority
(WTCB_Ptr
.Priority
) > mutex
.Prio_Ceiling
325 Result
:= semTake
(mutex
.Mutex
, WAIT_FOREVER
);
332 end pthread_mutex_lock
;
334 function pthread_mutex_unlock
335 (mutex
: access pthread_mutex_t
) return int
339 Result
:= semGive
(mutex
.Mutex
);
346 end pthread_mutex_unlock
;
348 function pthread_condattr_init
349 (attr
: access pthread_condattr_t
) return int
is
351 attr
.Flags
:= SEM_Q_PRIORITY
;
353 end pthread_condattr_init
;
355 function pthread_condattr_destroy
356 (attr
: access pthread_condattr_t
) return int
is
360 end pthread_condattr_destroy
;
362 function pthread_cond_init
363 (cond
: access pthread_cond_t
;
364 attr
: access pthread_condattr_t
) return int
369 -- Condition variables should be initially created
372 cond
.Sem
:= semBCreate
(attr
.Flags
, SEM_EMPTY
);
380 end pthread_cond_init
;
382 function pthread_cond_destroy
(cond
: access pthread_cond_t
) return int
is
386 Result
:= semDelete
(cond
.Sem
);
393 end pthread_cond_destroy
;
395 function pthread_cond_signal
396 (cond
: access pthread_cond_t
) return int
402 -- Disable task scheduling.
406 -- Iff someone is currently waiting on the condition variable
407 -- then release the semaphore; we don't want to leave the
408 -- semaphore in the full state because the next guy to do
409 -- a condition wait operation would not block.
411 if cond
.Waiting
> 0 then
412 Result
:= semGive
(cond
.Sem
);
414 -- One less thread waiting on the CV.
416 cond
.Waiting
:= cond
.Waiting
- 1;
423 -- Reenable task scheduling.
425 Status
:= taskUnlock
;
428 end pthread_cond_signal
;
430 function pthread_cond_wait
431 (cond
: access pthread_cond_t
;
432 mutex
: access pthread_mutex_t
) return int
437 -- Disable task scheduling.
441 -- Release the mutex as required by POSIX.
443 Result
:= semGive
(mutex
.Mutex
);
445 -- Indicate that there is another thread waiting on the CV.
447 cond
.Waiting
:= cond
.Waiting
+ 1;
449 -- Perform a blocking operation to take the CV semaphore.
450 -- Note that a blocking operation in VxWorks will reenable
451 -- task scheduling. When we are no longer blocked and control
452 -- is returned, task scheduling will again be disabled.
454 Result
:= semTake
(cond
.Sem
, WAIT_FOREVER
);
457 cond
.Waiting
:= cond
.Waiting
- 1;
461 -- Take the mutex as required by POSIX.
463 Status
:= semTake
(mutex
.Mutex
, WAIT_FOREVER
);
469 -- Reenable task scheduling.
471 Status
:= taskUnlock
;
474 end pthread_cond_wait
;
476 function pthread_cond_timedwait
477 (cond
: access pthread_cond_t
;
478 mutex
: access pthread_mutex_t
;
479 abstime
: access timespec
) return int
484 TS
: aliased timespec
;
486 Status
:= clock_gettime
(CLOCK_REALTIME
, TS
'Unchecked_Access);
488 -- Calculate the number of clock ticks for the timeout.
490 Ticks
:= To_Clock_Ticks
(To_Duration
(abstime
.all) - To_Duration
(TS
));
493 -- It is not worth the time to try to perform a semTake,
494 -- because we know it will always fail. A semTake with
495 -- ticks = 0 (NO_WAIT) will not block and therefore not
496 -- allow another task to give the semaphore. And if we've
497 -- designed pthread_cond_signal correctly, the semaphore
498 -- should never be left in a full state.
500 -- Make sure we give up the CPU.
502 Status
:= taskDelay
(0);
506 -- Disable task scheduling.
510 -- Release the mutex as required by POSIX.
512 Result
:= semGive
(mutex
.Mutex
);
514 -- Indicate that there is another thread waiting on the CV.
516 cond
.Waiting
:= cond
.Waiting
+ 1;
518 -- Perform a blocking operation to take the CV semaphore.
519 -- Note that a blocking operation in VxWorks will reenable
520 -- task scheduling. When we are no longer blocked and control
521 -- is returned, task scheduling will again be disabled.
523 Result
:= semTake
(cond
.Sem
, Ticks
);
526 if errno
= S_objLib_OBJ_TIMEOUT
then
531 cond
.Waiting
:= cond
.Waiting
- 1;
534 -- Take the mutex as required by POSIX.
536 Status
:= semTake
(mutex
.Mutex
, WAIT_FOREVER
);
542 -- Reenable task scheduling.
544 Status
:= taskUnlock
;
547 end pthread_cond_timedwait
;
549 ----------------------------
550 -- POSIX.1c Section 13 --
551 ----------------------------
553 function pthread_mutexattr_setprotocol
554 (attr
: access pthread_mutexattr_t
;
555 protocol
: int
) return int
is
557 if protocol
< PTHREAD_PRIO_NONE
558 or protocol
> PTHREAD_PRIO_PROTECT
563 attr
.Protocol
:= protocol
;
565 end pthread_mutexattr_setprotocol
;
567 function pthread_mutexattr_setprioceiling
568 (attr
: access pthread_mutexattr_t
;
569 prioceiling
: int
) return int
is
571 -- Our interface to the rest of the world is meant
572 -- to be POSIX compliant; keep the priority in POSIX
575 attr
.Prio_Ceiling
:= prioceiling
;
577 end pthread_mutexattr_setprioceiling
;
579 function pthread_setschedparam
582 param
: access struct_sched_param
) return int
586 -- Convert the POSIX priority to VxWorks native
589 Result
:= taskPrioritySet
(thread
,
590 To_Vxworks_Priority
(param
.sched_priority
));
592 end pthread_setschedparam
;
594 function sched_yield
return int
is
596 return taskDelay
(0);
599 function pthread_sched_rr_set_interval
(usecs
: int
) return int
is
603 -- Check to see if round-robin scheduling (time slicing)
604 -- is enabled. If the time slice is the default value (-1)
605 -- or any negative number, we will leave the kernel time
606 -- slice unchanged. If the time slice is 0, we disable
607 -- kernel time slicing by setting it to 0. Otherwise, we
608 -- set the kernel time slice to the specified value converted
613 if Time_Slice
> 0 then
614 D_Slice
:= Duration (Time_Slice
) / Duration (1_000_000
.0
);
615 Result
:= kernelTimeSlice
(To_Clock_Ticks
(D_Slice
));
618 if Time_Slice
= 0 then
619 Result
:= kernelTimeSlice
(0);
624 end pthread_sched_rr_set_interval
;
626 function pthread_attr_init
(attr
: access pthread_attr_t
) return int
is
628 attr
.Stacksize
:= 100000; -- What else can I do?
629 attr
.Detachstate
:= PTHREAD_CREATE_DETACHED
;
630 attr
.Priority
:= POSIX_SCHED_FIFO_LOW_PRI
;
631 attr
.Taskname
:= System
.Null_Address
;
633 end pthread_attr_init
;
635 function pthread_attr_destroy
(attr
: access pthread_attr_t
) return int
is
638 attr
.Detachstate
:= 0;
639 attr
.Priority
:= POSIX_SCHED_FIFO_LOW_PRI
;
640 attr
.Taskname
:= System
.Null_Address
;
642 end pthread_attr_destroy
;
644 function pthread_attr_setdetachstate
645 (attr
: access pthread_attr_t
;
646 detachstate
: int
) return int
is
648 attr
.Detachstate
:= detachstate
;
650 end pthread_attr_setdetachstate
;
652 function pthread_attr_setstacksize
653 (attr
: access pthread_attr_t
;
654 stacksize
: size_t
) return int
is
656 attr
.Stacksize
:= stacksize
;
658 end pthread_attr_setstacksize
;
660 -- In VxWorks tasks, we can set the task name. This
661 -- makes it really convenient for debugging.
663 function pthread_attr_setname_np
664 (attr
: access pthread_attr_t
;
665 name
: System
.Address
) return int
is
667 attr
.Taskname
:= name
;
669 end pthread_attr_setname_np
;
671 function pthread_create
672 (thread
: access pthread_t
;
673 attr
: access pthread_attr_t
;
674 start_routine
: Thread_Body
;
675 arg
: System
.Address
) return int
is
677 thread
.all := taskSpawn
(attr
.Taskname
,
678 To_Vxworks_Priority
(attr
.Priority
), VX_FP_TASK
, attr
.Stacksize
,
681 if thread
.all = -1 then
688 function pthread_detach
(thread
: pthread_t
) return int
is
693 procedure pthread_exit
(status
: System
.Address
) is
698 function pthread_self
return pthread_t
is
703 function pthread_equal
(t1
: pthread_t
; t2
: pthread_t
) return int
is
712 function pthread_setspecific
713 (key
: pthread_key_t
;
714 value
: System
.Address
) return int
718 if Integer (key
) not in Key_Storage
'Range then
722 Key_Storage
(Integer (key
)) := value
;
723 Result
:= taskVarAdd
(taskIdSelf
, Key_Storage
(Integer (key
))'Access);
725 -- We should be able to directly set the key with the following:
726 -- Key_Storage (key) := value;
727 -- but we'll be safe and use taskVarSet.
728 -- ??? Come back and revisit this.
730 Result
:= taskVarSet
(taskIdSelf
,
731 Key_Storage
(Integer (key
))'Access, value
);
733 end pthread_setspecific
;
735 function pthread_getspecific
(key
: pthread_key_t
) return System
.Address
is
737 return Key_Storage
(Integer (key
));
738 end pthread_getspecific
;
740 function pthread_key_create
741 (key
: access pthread_key_t
;
742 destructor
: destructor_pointer
) return int
is
744 Keys_Created
:= Keys_Created
+ 1;
746 if Keys_Created
not in Key_Storage
'Range then
750 key
.all := pthread_key_t
(Keys_Created
);
752 end pthread_key_create
;
758 function To_Duration
(TS
: timespec
) return Duration is
760 return Duration (TS
.ts_sec
) + Duration (TS
.ts_nsec
) / 10#
1#E9
;
767 function To_Timespec
(D
: Duration) return timespec
is
771 S
:= time_t
(Long_Long_Integer (D
));
772 F
:= D
- Duration (S
);
774 -- If F has negative value due to a round-up, adjust for positive F
780 return timespec
' (ts_sec => S,
781 ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
788 -- ??? - For now, we'll always get the system clock rate
789 -- since it is allowed to be changed during run-time in
790 -- VxWorks. A better method would be to provide an operation
791 -- to set it that so we can always know its value.
793 -- Another thing we should probably allow for is a resultant
794 -- tick count greater than int'Last. This should probably
795 -- be a procedure with two output parameters, one in the
796 -- range 0 .. int'Last, and another representing the overflow
799 function To_Clock_Ticks (D : Duration) return int is
800 Ticks : Long_Long_Integer;
801 Rate_Duration : Duration;
802 Ticks_Duration : Duration;
805 -- Ensure that the duration can be converted to ticks
806 -- at the current clock tick rate without overflowing.
808 Rate_Duration := Duration (sysClkRateGet);
810 if D > (Duration'Last / Rate_Duration) then
811 Ticks := Long_Long_Integer (int'Last);
814 -- We always want to round up to the nearest clock tick.
816 Ticks_Duration := D * Rate_Duration;
817 Ticks := Long_Long_Integer (Ticks_Duration);
819 if Ticks_Duration > Duration (Ticks) then
823 if Ticks > Long_Long_Integer (int'Last) then
824 Ticks := Long_Long_Integer (int'Last);
831 end System.OS_Interface;