diff options
Diffstat (limited to 'gcc/ada/5zosinte.adb')
| -rw-r--r-- | gcc/ada/5zosinte.adb | 717 |
1 files changed, 26 insertions, 691 deletions
diff --git a/gcc/ada/5zosinte.adb b/gcc/ada/5zosinte.adb index c578234c712..747022bf584 100644 --- a/gcc/ada/5zosinte.adb +++ b/gcc/ada/5zosinte.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.15 $ +-- $Revision$ -- -- --- Copyright (C) 1997-2001 Free Software Foundation -- +-- Copyright (C) 1997-2002 Free Software Foundation -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,8 +29,7 @@ -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- +-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ @@ -43,171 +42,22 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during -- tasking operations. It causes infinite loops and other problems. -with Interfaces.C; use Interfaces.C; - -with System.VxWorks; --- used for Wind_TCB_Ptr - -with Unchecked_Conversion; - package body System.OS_Interface is - use System.VxWorks; - - -- Option flags for taskSpawn - - VX_UNBREAKABLE : constant := 16#0002#; - VX_FP_TASK : constant := 16#0008#; - VX_FP_PRIVATE_ENV : constant := 16#0080#; - VX_NO_STACK_FILL : constant := 16#0100#; - - function taskSpawn - (name : System.Address; -- Pointer to task name - priority : int; - options : int; - stacksize : size_t; - start_routine : Thread_Body; - arg1 : System.Address; - arg2 : int := 0; - arg3 : int := 0; - arg4 : int := 0; - arg5 : int := 0; - arg6 : int := 0; - arg7 : int := 0; - arg8 : int := 0; - arg9 : int := 0; - arg10 : int := 0) return pthread_t; - pragma Import (C, taskSpawn, "taskSpawn"); - - procedure taskDelete (tid : pthread_t); - pragma Import (C, taskDelete, "taskDelete"); - - -- These are the POSIX scheduling priorities. These are enabled - -- when the global variable posixPriorityNumbering is 1. - - POSIX_SCHED_FIFO_LOW_PRI : constant := 0; - POSIX_SCHED_FIFO_HIGH_PRI : constant := 255; - POSIX_SCHED_RR_LOW_PRI : constant := 0; - POSIX_SCHED_RR_HIGH_PRI : constant := 255; - - -- These are the VxWorks native (default) scheduling priorities. - -- These are used when the global variable posixPriorityNumbering - -- is 0. - - SCHED_FIFO_LOW_PRI : constant := 255; - SCHED_FIFO_HIGH_PRI : constant := 0; - SCHED_RR_LOW_PRI : constant := 255; - SCHED_RR_HIGH_PRI : constant := 0; - - -- Global variable to enable POSIX priority numbering. - -- By default, it is 0 and VxWorks native priority numbering - -- is used. - - posixPriorityNumbering : int; - pragma Import (C, posixPriorityNumbering, "posixPriorityNumbering"); - - -- VxWorks will let you set round-robin scheduling globally - -- for all tasks, but not for individual tasks. Attempting - -- to set the scheduling policy for a specific task (using - -- sched_setscheduler) to something other than what the system - -- is currently using will fail. If you wish to change the - -- scheduling policy, then use the following function to set - -- it globally for all tasks. When ticks is 0, time slicing - -- (round-robin scheduling) is disabled. - - function kernelTimeSlice (ticks : int) return int; - pragma Import (C, kernelTimeSlice, "kernelTimeSlice"); + use type Interfaces.C.int; - function taskPriorityGet - (tid : pthread_t; - pPriority : access int) - return int; - pragma Import (C, taskPriorityGet, "taskPriorityGet"); + Low_Priority : constant := 255; + -- VxWorks native (default) lowest scheduling priority. - function taskPrioritySet - (tid : pthread_t; - newPriority : int) - return int; - pragma Import (C, taskPrioritySet, "taskPrioritySet"); - - function To_Wind_TCB_Ptr is - new Unchecked_Conversion (pthread_t, Wind_TCB_Ptr); - - - -- Error codes (errno). The lower level 16 bits are the - -- error code, with the upper 16 bits representing the - -- module number in which the error occurred. By convention, - -- the module number is 0 for UNIX errors. VxWorks reserves - -- module numbers 1-500, with the remaining module numbers - -- being available for user applications. - - M_objLib : constant := 61 * 2**16; - -- semTake() failure with ticks = NO_WAIT - S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; - -- semTake() timeout with ticks > NO_WAIT - S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; - - -- We use two different kinds of VxWorks semaphores: mutex - -- and binary semaphores. A null (0) ID is returned when - -- a semaphore cannot be created. Binary semaphores and common - -- operations are declared in the spec of this package, - -- as they are used to implement hardware interrupt handling - - function semMCreate - (options : int) return SEM_ID; - pragma Import (C, semMCreate, "semMCreate"); - - - function taskLock return int; - pragma Import (C, taskLock, "taskLock"); - - function taskUnlock return int; - pragma Import (C, taskUnlock, "taskUnlock"); - - ------------------------------------------------------- - -- Convenience routines to convert between VxWorks -- - -- priority and POSIX priority. -- - ------------------------------------------------------- - - function To_Vxworks_Priority (Priority : in int) return int; - pragma Inline (To_Vxworks_Priority); - - function To_Posix_Priority (Priority : in int) return int; - pragma Inline (To_Posix_Priority); - - function To_Vxworks_Priority (Priority : in int) return int is - begin - return SCHED_FIFO_LOW_PRI - Priority; - end To_Vxworks_Priority; - - function To_Posix_Priority (Priority : in int) return int is - begin - return SCHED_FIFO_LOW_PRI - Priority; - end To_Posix_Priority; - - ---------------------------------------- - -- Implementation of POSIX routines -- - ---------------------------------------- - - ----------------------------------------- - -- Nonstandard Thread Initialization -- - ----------------------------------------- - - procedure pthread_init is - begin - Keys_Created := 0; - Time_Slice := -1; - end pthread_init; - - --------------------------- - -- POSIX.1c Section 3 -- - --------------------------- + ------------- + -- sigwait -- + ------------- function sigwait (set : access sigset_t; sig : access Signal) return int is - Result : Interfaces.C.int; + Result : int; function sigwaitinfo (set : access sigset_t; sigvalue : System.Address) return int; @@ -225,532 +75,6 @@ package body System.OS_Interface is end if; end sigwait; - ---------------------------- - -- POSIX.1c Section 11 -- - ---------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int is - begin - -- Let's take advantage of VxWorks priority inversion - -- protection. - -- - -- ??? - Do we want to also specify SEM_DELETE_SAFE??? - - attr.Flags := int (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); - - -- Initialize the ceiling priority to the maximim priority. - -- We will use POSIX priorities since these routines are - -- emulating POSIX routines. - - attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; - attr.Protocol := PTHREAD_PRIO_INHERIT; - return 0; - end pthread_mutexattr_init; - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int is - begin - attr.Flags := 0; - attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; - attr.Protocol := PTHREAD_PRIO_INHERIT; - return 0; - end pthread_mutexattr_destroy; - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int - is - Result : int := 0; - - begin - -- A mutex should initially be created full and the task - -- protected from deletion while holding the semaphore. - - mutex.Mutex := semMCreate (attr.Flags); - mutex.Prio_Ceiling := attr.Prio_Ceiling; - mutex.Protocol := attr.Protocol; - - if mutex.Mutex = 0 then - Result := errno; - end if; - - return Result; - end pthread_mutex_init; - - function pthread_mutex_destroy - (mutex : access pthread_mutex_t) return int - is - Result : STATUS; - begin - Result := semDelete (mutex.Mutex); - - if Result /= 0 then - Result := errno; - end if; - - mutex.Mutex := 0; -- Ensure the mutex is properly cleaned. - mutex.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; - mutex.Protocol := PTHREAD_PRIO_INHERIT; - return Result; - end pthread_mutex_destroy; - - function pthread_mutex_lock - (mutex : access pthread_mutex_t) return int - is - Result : int; - WTCB_Ptr : Wind_TCB_Ptr; - begin - WTCB_Ptr := To_Wind_TCB_Ptr (taskIdSelf); - - if WTCB_Ptr = null then - return errno; - end if; - - -- Check the current inherited priority in the WIND_TCB - -- against the mutex ceiling priority and return EINVAL - -- upon a ceiling violation. - -- - -- We always convert the VxWorks priority to POSIX priority - -- in case the current priority ordering has changed (see - -- posixPriorityNumbering). The mutex ceiling priority is - -- maintained as POSIX compatible. - - if mutex.Protocol = PTHREAD_PRIO_PROTECT and then - To_Posix_Priority (WTCB_Ptr.Priority) > mutex.Prio_Ceiling - then - return EINVAL; - end if; - - Result := semTake (mutex.Mutex, WAIT_FOREVER); - - if Result /= 0 then - Result := errno; - end if; - - return Result; - end pthread_mutex_lock; - - function pthread_mutex_unlock - (mutex : access pthread_mutex_t) return int - is - Result : int; - begin - Result := semGive (mutex.Mutex); - - if Result /= 0 then - Result := errno; - end if; - - return Result; - end pthread_mutex_unlock; - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int is - begin - attr.Flags := SEM_Q_PRIORITY; - return 0; - end pthread_condattr_init; - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int is - begin - attr.Flags := 0; - return 0; - end pthread_condattr_destroy; - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int - is - Result : int := 0; - - begin - -- Condition variables should be initially created - -- empty. - - cond.Sem := semBCreate (attr.Flags, SEM_EMPTY); - cond.Waiting := 0; - - if cond.Sem = 0 then - Result := errno; - end if; - - return Result; - end pthread_cond_init; - - function pthread_cond_destroy (cond : access pthread_cond_t) return int is - Result : int; - - begin - Result := semDelete (cond.Sem); - - if Result /= 0 then - Result := errno; - end if; - - return Result; - end pthread_cond_destroy; - - function pthread_cond_signal - (cond : access pthread_cond_t) return int - is - Result : int := 0; - Status : int; - - begin - -- Disable task scheduling. - - Status := taskLock; - - -- Iff someone is currently waiting on the condition variable - -- then release the semaphore; we don't want to leave the - -- semaphore in the full state because the next guy to do - -- a condition wait operation would not block. - - if cond.Waiting > 0 then - Result := semGive (cond.Sem); - - -- One less thread waiting on the CV. - - cond.Waiting := cond.Waiting - 1; - - if Result /= 0 then - Result := errno; - end if; - end if; - - -- Reenable task scheduling. - - Status := taskUnlock; - - return Result; - end pthread_cond_signal; - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int - is - Result : int; - Status : int; - begin - -- Disable task scheduling. - - Status := taskLock; - - -- Release the mutex as required by POSIX. - - Result := semGive (mutex.Mutex); - - -- Indicate that there is another thread waiting on the CV. - - cond.Waiting := cond.Waiting + 1; - - -- Perform a blocking operation to take the CV semaphore. - -- Note that a blocking operation in VxWorks will reenable - -- task scheduling. When we are no longer blocked and control - -- is returned, task scheduling will again be disabled. - - Result := semTake (cond.Sem, WAIT_FOREVER); - - if Result /= 0 then - cond.Waiting := cond.Waiting - 1; - Result := EINVAL; - end if; - - -- Take the mutex as required by POSIX. - - Status := semTake (mutex.Mutex, WAIT_FOREVER); - - if Status /= 0 then - Result := EINVAL; - end if; - - -- Reenable task scheduling. - - Status := taskUnlock; - - return Result; - end pthread_cond_wait; - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int - is - Result : int; - Status : int; - Ticks : int; - TS : aliased timespec; - begin - Status := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); - - -- Calculate the number of clock ticks for the timeout. - - Ticks := To_Clock_Ticks (To_Duration (abstime.all) - To_Duration (TS)); - - if Ticks <= 0 then - -- It is not worth the time to try to perform a semTake, - -- because we know it will always fail. A semTake with - -- ticks = 0 (NO_WAIT) will not block and therefore not - -- allow another task to give the semaphore. And if we've - -- designed pthread_cond_signal correctly, the semaphore - -- should never be left in a full state. - -- - -- Make sure we give up the CPU. - - Status := taskDelay (0); - return ETIMEDOUT; - end if; - - -- Disable task scheduling. - - Status := taskLock; - - -- Release the mutex as required by POSIX. - - Result := semGive (mutex.Mutex); - - -- Indicate that there is another thread waiting on the CV. - - cond.Waiting := cond.Waiting + 1; - - -- Perform a blocking operation to take the CV semaphore. - -- Note that a blocking operation in VxWorks will reenable - -- task scheduling. When we are no longer blocked and control - -- is returned, task scheduling will again be disabled. - - Result := semTake (cond.Sem, Ticks); - - if Result /= 0 then - if errno = S_objLib_OBJ_TIMEOUT then - Result := ETIMEDOUT; - else - Result := EINVAL; - end if; - cond.Waiting := cond.Waiting - 1; - end if; - - -- Take the mutex as required by POSIX. - - Status := semTake (mutex.Mutex, WAIT_FOREVER); - - if Status /= 0 then - Result := EINVAL; - end if; - - -- Reenable task scheduling. - - Status := taskUnlock; - - return Result; - end pthread_cond_timedwait; - - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int is - begin - if protocol < PTHREAD_PRIO_NONE - or protocol > PTHREAD_PRIO_PROTECT - then - return EINVAL; - end if; - - attr.Protocol := protocol; - return 0; - end pthread_mutexattr_setprotocol; - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int is - begin - -- Our interface to the rest of the world is meant - -- to be POSIX compliant; keep the priority in POSIX - -- format. - - attr.Prio_Ceiling := prioceiling; - return 0; - end pthread_mutexattr_setprioceiling; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int - is - Result : int; - begin - -- Convert the POSIX priority to VxWorks native - -- priority. - - Result := taskPrioritySet (thread, - To_Vxworks_Priority (param.sched_priority)); - return 0; - end pthread_setschedparam; - - function sched_yield return int is - begin - return taskDelay (0); - end sched_yield; - - function pthread_sched_rr_set_interval (usecs : int) return int is - Result : int := 0; - D_Slice : Duration; - begin - -- Check to see if round-robin scheduling (time slicing) - -- is enabled. If the time slice is the default value (-1) - -- or any negative number, we will leave the kernel time - -- slice unchanged. If the time slice is 0, we disable - -- kernel time slicing by setting it to 0. Otherwise, we - -- set the kernel time slice to the specified value converted - -- to clock ticks. - - Time_Slice := usecs; - - if Time_Slice > 0 then - D_Slice := Duration (Time_Slice) / Duration (1_000_000.0); - Result := kernelTimeSlice (To_Clock_Ticks (D_Slice)); - - else - if Time_Slice = 0 then - Result := kernelTimeSlice (0); - end if; - end if; - - return Result; - end pthread_sched_rr_set_interval; - - function pthread_attr_init (attr : access pthread_attr_t) return int is - begin - attr.Stacksize := 100000; -- What else can I do? - attr.Detachstate := PTHREAD_CREATE_DETACHED; - attr.Priority := POSIX_SCHED_FIFO_LOW_PRI; - attr.Taskname := System.Null_Address; - return 0; - end pthread_attr_init; - - function pthread_attr_destroy (attr : access pthread_attr_t) return int is - begin - attr.Stacksize := 0; - attr.Detachstate := 0; - attr.Priority := POSIX_SCHED_FIFO_LOW_PRI; - attr.Taskname := System.Null_Address; - return 0; - end pthread_attr_destroy; - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int is - begin - attr.Detachstate := detachstate; - return 0; - end pthread_attr_setdetachstate; - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int is - begin - attr.Stacksize := stacksize; - return 0; - end pthread_attr_setstacksize; - - -- In VxWorks tasks, we can set the task name. This - -- makes it really convenient for debugging. - - function pthread_attr_setname_np - (attr : access pthread_attr_t; - name : System.Address) return int is - begin - attr.Taskname := name; - return 0; - end pthread_attr_setname_np; - - function pthread_create - (thread : access pthread_t; - attr : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int is - begin - thread.all := taskSpawn (attr.Taskname, - To_Vxworks_Priority (attr.Priority), VX_FP_TASK, attr.Stacksize, - start_routine, arg); - - if thread.all = -1 then - return -1; - else - return 0; - end if; - end pthread_create; - - function pthread_detach (thread : pthread_t) return int is - begin - return 0; - end pthread_detach; - - procedure pthread_exit (status : System.Address) is - begin - taskDelete (0); - end pthread_exit; - - function pthread_self return pthread_t is - begin - return taskIdSelf; - end pthread_self; - - function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int is - begin - if t1 = t2 then - return 1; - else - return 0; - end if; - end pthread_equal; - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int - is - Result : int; - begin - if Integer (key) not in Key_Storage'Range then - return EINVAL; - end if; - - Key_Storage (Integer (key)) := value; - Result := taskVarAdd (taskIdSelf, Key_Storage (Integer (key))'Access); - - -- We should be able to directly set the key with the following: - -- Key_Storage (key) := value; - -- but we'll be safe and use taskVarSet. - -- ??? Come back and revisit this. - - Result := taskVarSet (taskIdSelf, - Key_Storage (Integer (key))'Access, value); - return Result; - end pthread_setspecific; - - function pthread_getspecific (key : pthread_key_t) return System.Address is - begin - return Key_Storage (Integer (key)); - end pthread_getspecific; - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int is - begin - Keys_Created := Keys_Created + 1; - - if Keys_Created not in Key_Storage'Range then - return ENOMEM; - end if; - - key.all := pthread_key_t (Keys_Created); - return 0; - end pthread_key_create; - ----------------- -- To_Duration -- ----------------- @@ -777,21 +101,31 @@ package body System.OS_Interface is S := S - 1; F := F + 1.0; end if; + return timespec' (ts_sec => S, ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; + ------------------------- + -- To_VxWorks_Priority -- + ------------------------- + + function To_VxWorks_Priority (Priority : in int) return int is + begin + return Low_Priority - Priority; + end To_VxWorks_Priority; + -------------------- -- To_Clock_Ticks -- -------------------- -- ??? - For now, we'll always get the system clock rate -- since it is allowed to be changed during run-time in - -- VxWorks. A better method would be to provide an operation + -- VxWorks. A better method would be to provide an operation -- to set it that so we can always know its value. -- -- Another thing we should probably allow for is a resultant - -- tick count greater than int'Last. This should probably + -- tick count greater than int'Last. This should probably -- be a procedure with two output parameters, one in the -- range 0 .. int'Last, and another representing the overflow -- count. @@ -800,7 +134,11 @@ package body System.OS_Interface is Ticks : Long_Long_Integer; Rate_Duration : Duration; Ticks_Duration : Duration; + begin + if D < 0.0 then + return -1; + end if; -- Ensure that the duration can be converted to ticks -- at the current clock tick rate without overflowing. @@ -809,10 +147,7 @@ package body System.OS_Interface is if D > (Duration'Last / Rate_Duration) then Ticks := Long_Long_Integer (int'Last); - else - -- We always want to round up to the nearest clock tick. - Ticks_Duration := D * Rate_Duration; Ticks := Long_Long_Integer (Ticks_Duration); |