------------------------------------------------------------------------ -- Howard Eng 2/94 -- -- Unixpros, Inc. -- -- -- -- This package defines the implementation of "pthread_" using Ada -- ------------------------------------------------------------------------ with SYSTEM; with TEXT_IO; with CALENDAR; with UNCHECKED_CONVERSION; with UNCHECKED_DEALLOCATION; with DCE_ADA_SEMAPHORE; package body DCE_THREADS is -- -- ADA_MAIN_THREAD is the thread handle for the "main thread". -- ADA_MAIN_THREAD : CMA_TYPES.ADA_PTHREAD_T := CMA_TYPES.CREATE_MAIN_TASK; procedure UNLOCK_MUTEX( MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T ); procedure LOCK_MUTEX( MUTEX : in CMA_TYPES.ADA_PTHREAD_MUTEX_T ); procedure ADA_THD_RAISE_EXCEPTION( EXC : in CMA_TYPES.ADA_PTHREAD_EXC_T ); pragma INTERFACE( C, ADA_THD_RAISE_EXCEPTION ); procedure ADA_THD_UNSET32( VALUE : in SYSTEM.ADDRESS ); pragma INTERFACE( C, ADA_THD_UNSET32 ); function ADA_THD_TEST_AND_SET32( VALUE : in SYSTEM.ADDRESS ) return CMA_TYPES.C_INTEGER; pragma INTERFACE( C, ADA_THD_TEST_AND_SET32 ); ------------------------------------------------------------------------ -- -- "ada_test_asynccancel()" - Checks cancelability by checking -- current state, async cancelability, -- and general cancelability. If the -- thread has been marked for -- cancellation and async cancellation -- and general cancellation are ON, then -- the thread is exited. -- ------------------------------------------------------------------------ procedure ADA_TESTASYNCCANCEL is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; use CMA_TYPES; begin if HANDLE /= CMA_TYPES.NULL_ADA_PTHREAD_T then if HANDLE.STATE = CMA_TYPES.CANCELLED and HANDLE.ASYNC_CANCEL = CMA_TYPES.CANCEL_ON and HANDLE.GENERAL_CANCEL = CMA_TYPES.CANCEL_ON then HANDLE.STATE := CMA_TYPES.RUNNING; ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_PTHREAD_CANCEL_E ); end if; end if; end ADA_TESTASYNCCANCEL; ------------------------------------------------------------------------ -- -- Yields the processor by executing a delay. -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_YIELD is begin ADA_TESTASYNCCANCEL; delay 0.0; end ADA_PTHREAD_YIELD; ------------------------------------------------------------------------ -- -- "pthread_cancel()". - Cancels the thread identified by THREAD_ID. -- If the thread is waiting on a CV then a -- broadcast is sent to the CV so that it can be -- deleted. If the thread is trying to join with -- another thread, then the target thread's CV -- is broadcast. -- ------------------------------------------------------------------------ function ADA_PTHREAD_CANCEL( PTHREAD : in CMA_TYPES.PTHREAD_T ) return CMA_TYPES.C_INTEGER is THREAD_HANDLE : CMA_TYPES.ADA_PTHREAD_T; CV : CMA_TYPES.ADA_PTHREAD_COND_T; ANSWER : CMA_TYPES.C_INTEGER := 0; EXECUTING_DELAY : BOOLEAN := FALSE; WAITING_ON_JOIN : BOOLEAN := FALSE; WAIT_ON_SELECT : BOOLEAN := FALSE; use CMA_TYPES; procedure ADA_THD_THREAD_ALERT( TCB : in SYSTEM.ADDRESS ); pragma INTERFACE(C, ADA_THD_THREAD_ALERT); begin THREAD_HANDLE := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD ); ADA_THD_THREAD_ALERT( THREAD_HANDLE.CMA_THREAD_TCB ); THREAD_HANDLE.INT_LOCK.LOCK; THREAD_HANDLE.STATE := CMA_TYPES.CANCELLED; CV := THREAD_HANDLE.CV; if THREAD_HANDLE.JOIN_TGT /= CMA_TYPES.NULL_ADA_PTHREAD_T then WAITING_ON_JOIN := TRUE; elsif THREAD_HANDLE.EXECUTING_DELAY then if THREAD_HANDLE.WAIT_CV = CMA_TYPES.NULL_INT_CV then ADA_THD_RAISE_EXCEPTION( ADA_USE_ERROR_E ); end if; EXECUTING_DELAY := TRUE; end if; WAIT_ON_SELECT := THREAD_HANDLE.SELECT_WAIT; THREAD_HANDLE.INT_LOCK.UNLOCK; -- -- If the target thread is waiting on a Condition Variable, -- broadcast to the CV to wake him up. -- if CV /= CMA_TYPES.NULL_ADA_PTHREAD_COND_T then LOCK_MUTEX( CV.MUTEX ); CV.SEM.WAKE_ALL; UNLOCK_MUTEX( CV.MUTEX ); end if; -- -- If the target thread is waiting on a join, signal to the join CV -- to wake him up. -- if WAITING_ON_JOIN then THREAD_HANDLE.JOIN_TGT.JOIN_CV.WAKE_ALL; end if; -- -- If the target thread is executing a delay or select , signal to the -- internal CV to break him out of it. -- if EXECUTING_DELAY or WAIT_ON_SELECT then THREAD_HANDLE.WAIT_CV.WAKE_ALL; end if; ADA_TESTASYNCCANCEL; return ANSWER; end ADA_PTHREAD_CANCEL; ------------------------------------------------------------------------ -- -- "pthread_detach()". - Sets the thread's "DETACHED" field to true, -- so that when it is cancelled it's memory can -- be freed. Once the thread is detached the -- all operations on it are invalid. -- ------------------------------------------------------------------------ function ADA_PTHREAD_DETACH( PTHREAD : in CMA_TYPES.PTHREAD_T ) return CMA_TYPES.C_INTEGER is THREAD : CMA_TYPES.ADA_PTHREAD_T; ANSWER : CMA_TYPES.C_INTEGER := 0; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; THREAD := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD ); THREAD.DETACHED := TRUE; return ANSWER; end ADA_PTHREAD_DETACH; ------------------------------------------------------------------------ -- -- "pthread_delay_np()". - Causes the calling thread to be -- delayed by "INTERVAL" seconds. -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_DELAY_NP( INTERVAL : in CMA_TYPES.TIME_SPEC_P ) is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; WAIT_T : DURATION; function ADA_THD_LONG_TO_FLOAT( VAL : in CMA_TYPES.LONG ) return FLOAT; pragma INTERFACE( C, ADA_THD_LONG_TO_FLOAT ); use CMA_TYPES; begin ADA_PTHREAD_TESTCANCEL; WAIT_T := DURATION( ( ADA_THD_LONG_TO_FLOAT( INTERVAL.TV_SEC ) ) + ( ADA_THD_LONG_TO_FLOAT( INTERVAL.TV_NSEC )/1.0e+9) ); HANDLE.INT_LOCK.LOCK; HANDLE.EXECUTING_DELAY := TRUE; HANDLE.INT_LOCK.UNLOCK; HANDLE.WAIT_CV.TIMED_WAIT( WAIT_T ); HANDLE.INT_LOCK.LOCK; HANDLE.EXECUTING_DELAY := FALSE; HANDLE.INT_LOCK.UNLOCK; ADA_PTHREAD_TESTCANCEL; end ADA_PTHREAD_DELAY_NP; ------------------------------------------------------------------------ -- -- "pthread_exit()". - A thread exits by executing a "longjmp" out of -- of its "thread" routine. This will cause -- control to pass back to the thread entry where -- processing started. The "longjmp" resumes -- Ada tasking. -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_EXIT( EXIT_STATUS : in CMA_TYPES.PTHREAD_ADDR_T ) is THREAD_HANDLE : CMA_TYPES.ADA_PTHREAD_T; begin THREAD_HANDLE := ADA_PTHREAD_SELF; THREAD_HANDLE.INT_LOCK.LOCK; THREAD_HANDLE.EXIT_STATUS := EXIT_STATUS; THREAD_HANDLE.INT_LOCK.UNLOCK; ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_EXIT_THREAD_E ); end ADA_PTHREAD_EXIT; ------------------------------------------------------------------------ -- -- "pthread_setcancel()". - Sets the task's general cancelablilty -- ------------------------------------------------------------------------ function ADA_PTHREAD_SETCANCEL( STATE : in CMA_TYPES.C_INTEGER ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T; CURRENT_STATE : CMA_TYPES.CANCEL_STATE; ANSWER : CMA_TYPES.C_INTEGER; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; HANDLE := ADA_PTHREAD_SELF; CURRENT_STATE := HANDLE.GENERAL_CANCEL; if( STATE = 0 ) then HANDLE.GENERAL_CANCEL := CMA_TYPES.CANCEL_OFF; else HANDLE.GENERAL_CANCEL := CMA_TYPES.CANCEL_ON; end if; if( CURRENT_STATE = CMA_TYPES.CANCEL_ON ) then ANSWER := 1; else ANSWER := 0; end if; return ANSWER; end ADA_PTHREAD_SETCANCEL; ------------------------------------------------------------------------ -- -- "pthread_setasynccancel()". - Sets the task's async cancelability -- ------------------------------------------------------------------------ function ADA_PTHREAD_SETASYNCCANCEL( STATE : in CMA_TYPES.C_INTEGER ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T; CURRENT_STATE : CMA_TYPES.CANCEL_STATE; ANSWER : CMA_TYPES.C_INTEGER; use CMA_TYPES; begin -- ADA_PTHREAD_TESTCANCEL; HANDLE := ADA_PTHREAD_SELF; CURRENT_STATE := HANDLE.ASYNC_CANCEL; if( STATE = 0 ) then HANDLE.ASYNC_CANCEL := CMA_TYPES.CANCEL_OFF; else HANDLE.ASYNC_CANCEL := CMA_TYPES.CANCEL_ON; end if; if( CURRENT_STATE = CMA_TYPES.CANCEL_ON ) then ANSWER := 1; else ANSWER := 0; end if; return ANSWER; end ADA_PTHREAD_SETASYNCCANCEL; ------------------------------------------------------------------------ -- -- "pthread_create()". - Creates an Ada Task. A new task is created -- along with a task control handle. This -- record is later stored in an internal tree so -- it can be recovered based on task TCB. The -- address of the task control record is -- returned as the "cma_t_address" member of the -- "cma_t_handle" structure. This is because -- some of the pthread calls pass "pthread_t" by -- value and some by reference. Either way, the -- control record can be retrieved. Processing -- for the thread begins by calling the task's -- START entry. -- -- CLEANUP_HNDLRS is the tree root of a list of -- cleanup handlers. -- -- KEY_LIST is the tree root of list of "pthread" -- keys. -- -- CMA_THREAD_TCB is a pointer to a CMA pthread -- TCB. -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_CREATE( PTHREAD : in CMA_TYPES.PTHREAD_T; ATTR : in CMA_TYPES.PTHREAD_ATTR_T; START_ROUTINE : in CMA_TYPES.PTHREAD_STARTROUTINE_T; ARG : in CMA_TYPES.PTHREAD_ADDR_T ) is CMA_THREAD_PTR : CMA_TYPES.CMA_THREAD_TYPE; HANDLE : CMA_TYPES.ADA_PTHREAD_T; THREAD_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; function ADA_THD_CREATE_CMA_THREAD_TCB( CV : in CMA_TYPES.INTERNAL_CV; MUTEX : in CMA_TYPES.INTERNAL_LOCK; LOCK : in SYSTEM.ADDRESS ) return SYSTEM.ADDRESS; pragma INTERFACE( C, ADA_THD_CREATE_CMA_THREAD_TCB ); use CMA_TYPES; begin ADA_TESTASYNCCANCEL; CMA_THREAD_PTR := new CMA_TYPES.CMA_THREAD_TASK_TYPE; HANDLE := new CMA_TYPES.ADA_PTHREAD_T_HANDLE; THREAD_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); if THREAD_ATTR /= PTHREADATTR_DEFAULT then HANDLE.SCHEDULER := THREAD_ATTR.SCHED; HANDLE.PRIORITY := THREAD_ATTR.PRIORITY; end if; HANDLE.TASK_ID := CMA_THREAD_PTR; HANDLE.WAIT_MUTEX := CMA_TYPES.ADA_THD_CREATE_INT_LOCK; HANDLE.WAIT_CV := CMA_TYPES.ADA_THD_CREATE_INT_CV; HANDLE.CMA_THREAD_TCB := ADA_THD_CREATE_CMA_THREAD_TCB( HANDLE.WAIT_CV, HANDLE.WAIT_MUTEX, HANDLE.INT_LOCK'ADDRESS ); PTHREAD.FIELD1 := CMA_TYPES.ADA_PTHREAD_T_TO_CMA_T_ADDRESS( HANDLE ); CMA_THREAD_PTR.START( HANDLE, START_ROUTINE, ARG ); exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_PTHREAD_CREATE; ------------------------------------------------------------------------ -- -- ada_dce_task_register - Makes the threads runtime aware of the -- current task. A new TCB is allocated for -- the task and the TCB is added to the -- internal list. -- -- NOTE: This call must be made for all tasks that -- will be making RPC calls or going through -- the pthreads runtime -- ------------------------------------------------------------------------ procedure ADA_DCE_TASK_REGISTER is HANDLE : CMA_TYPES.ADA_PTHREAD_T; function ADA_THD_CREATE_CMA_THREAD_TCB( CV : in CMA_TYPES.INTERNAL_CV; MUTEX : in CMA_TYPES.INTERNAL_LOCK; LOCK : in SYSTEM.ADDRESS ) return SYSTEM.ADDRESS; pragma INTERFACE( C, ADA_THD_CREATE_CMA_THREAD_TCB ); procedure ADA_THD_ADD_TASK_TO_LIST( THREAD_HANDLE : in CMA_TYPES.ADA_PTHREAD_T; TCB_ID : in SYSTEM.ADDRESS ); pragma INTERFACE( C, ADA_THD_ADD_TASK_TO_LIST ); function ADA_THD_GET_TASK_TCB_PTR return SYSTEM.ADDRESS; pragma INTERFACE( C, ADA_THD_GET_TASK_TCB_PTR ); use CMA_TYPES; begin ADA_TESTASYNCCANCEL; HANDLE := new CMA_TYPES.ADA_PTHREAD_T_HANDLE; HANDLE.TASK_ID := CMA_TYPES.ADDRESS_TO_THREAD( ADA_THD_GET_TASK_TCB_PTR ); HANDLE.WAIT_MUTEX := CMA_TYPES.ADA_THD_CREATE_INT_LOCK; HANDLE.WAIT_CV := CMA_TYPES.ADA_THD_CREATE_INT_CV; HANDLE.CMA_THREAD_TCB := ADA_THD_CREATE_CMA_THREAD_TCB( HANDLE.WAIT_CV, HANDLE.WAIT_MUTEX, HANDLE.INT_LOCK'ADDRESS ); HANDLE.TCB_PTR := CMA_TYPES.THREAD_TO_ADDRESS( HANDLE.TASK_ID ); ADA_THD_ADD_TASK_TO_LIST( HANDLE, HANDLE.TCB_PTR ); exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_DCE_TASK_REGISTER; ------------------------------------------------------------------------ -- -- "pthread_equal()". - Checks to see if 2 threads are equal by -- comparing their respective TASK and TCB Ids. -- If they're equal then 1 is returned. -- Otherwise, 0 is returned. -- ------------------------------------------------------------------------ function ADA_PTHREAD_EQUAL( PTHREAD1 : in CMA_TYPES.PTHREAD_T; PTHREAD2 : in CMA_TYPES.PTHREAD_T ) return CMA_TYPES.C_INTEGER is X : CMA_TYPES.ADA_PTHREAD_T; Y : CMA_TYPES.ADA_PTHREAD_T; EQUAL : CMA_TYPES.C_INTEGER; use SYSTEM; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; X := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD1 ); Y := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD2 ); if ( X.TCB_PTR = Y.TCB_PTR and X.TASK_ID = Y.TASK_ID ) then EQUAL := 1; else EQUAL := 0; end if; return EQUAL; end ADA_PTHREAD_EQUAL; ------------------------------------------------------------------------ -- -- Joins the current thread to the target thread. This is performed by -- adding the target thread to the current thread's "JOIN_TGT" member, -- and waiting on the target thread's "JOIN_CV" condition variable. -- ------------------------------------------------------------------------ procedure JOIN_TO_THREAD( HANDLE : in CMA_TYPES.ADA_PTHREAD_T; TARGET : in CMA_TYPES.ADA_PTHREAD_T ) is TGT_STATUS : CMA_TYPES.THREAD_STATE_T; OK_TO_EXIT : BOOLEAN := FALSE; use CMA_TYPES; begin HANDLE.INT_LOCK.LOCK; HANDLE.JOIN_TGT := TARGET; HANDLE.INT_LOCK.UNLOCK; TARGET.INT_LOCK.LOCK; TARGET.JOIN_CNT := TARGET.JOIN_CNT + 1; while not OK_TO_EXIT loop TGT_STATUS := TARGET.STATE; if( TGT_STATUS = CMA_TYPES.EXITED or HANDLE.STATE = CMA_TYPES.CANCELLED ) then OK_TO_EXIT := TRUE; TARGET.JOIN_CNT := TARGET.JOIN_CNT - 1; else if TARGET.JOIN_CV = CMA_TYPES.NULL_INT_CV then TARGET.JOIN_CV := new CMA_TYPES.INTERNAL_CV_TYPE; end if; TARGET.INT_LOCK.UNLOCK; TARGET.JOIN_CV.WAIT; TARGET.INT_LOCK.LOCK; end if; end loop; if TARGET.JOIN_CNT = 0 and TARGET.JOIN_CV /= CMA_TYPES.NULL_INT_CV then CMA_TYPES.FREE( TARGET.JOIN_CV ); TARGET.JOIN_CV := CMA_TYPES.NULL_INT_CV; end if; TARGET.INT_LOCK.UNLOCK; HANDLE.INT_LOCK.LOCK; HANDLE.JOIN_TGT := CMA_TYPES.NULL_ADA_PTHREAD_T; HANDLE.INT_LOCK.UNLOCK; end JOIN_TO_THREAD; ------------------------------------------------------------------------ -- -- "pthread_join()" - Executes a join by waiting until the target -- thread calls "pthread_exit()". The exit -- status is then retrieved from the task's -- control record. -- ------------------------------------------------------------------------ function ADA_PTHREAD_JOIN( PTHREAD : in CMA_TYPES.PTHREAD_T; STATUS : in CMA_TYPES.C_INTEGER_P ) return CMA_TYPES.PTHREAD_ADDR_T is ME : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; HANDLE : CMA_TYPES.ADA_PTHREAD_T; EXIT_STATUS : CMA_TYPES.PTHREAD_ADDR_T; use CMA_TYPES; begin ADA_PTHREAD_TESTCANCEL; HANDLE := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD ); if HANDLE = ME then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_EDEADLK_E ); end if; STATUS.all := 0; if HANDLE.DETACHED then ADA_THD_RAISE_EXCEPTION( ADA_INVALID_OBJ_E ); STATUS.all := -1; else if HANDLE.STATE /= CMA_TYPES.EXITED then JOIN_TO_THREAD( ME, HANDLE ); ADA_PTHREAD_TESTCANCEL; end if; HANDLE.INT_LOCK.LOCK; EXIT_STATUS := HANDLE.EXIT_STATUS; HANDLE.INT_LOCK.UNLOCK; end if; return EXIT_STATUS; end ADA_PTHREAD_JOIN; function ADA_PTHREAD_SETSCHEDULER( PTHREAD : in CMA_TYPES.PTHREAD_T; SCHEDULER : in CMA_TYPES.C_INTEGER; PRIORITY : in CMA_TYPES.C_INTEGER ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T; STATUS : CMA_TYPES.C_INTEGER := 0; begin ADA_PTHREAD_TESTCANCEL; HANDLE := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD ); HANDLE.SCHEDULER := SCHEDULER; HANDLE.PRIORITY := PRIORITY; return STATUS; end ADA_PTHREAD_SETSCHEDULER; function ADA_PTHREAD_GETSCHEDULER( PTHREAD : in CMA_TYPES.PTHREAD_T ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T; begin ADA_PTHREAD_TESTCANCEL; HANDLE := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD ); return HANDLE.SCHEDULER; end ADA_PTHREAD_GETSCHEDULER; function ADA_PTHREAD_SETPRIO( PTHREAD : in CMA_TYPES.PTHREAD_T; PRIORITY : in CMA_TYPES.C_INTEGER ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T; STATUS : CMA_TYPES.C_INTEGER := 0; begin ADA_PTHREAD_TESTCANCEL; HANDLE := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD ); HANDLE.PRIORITY := PRIORITY; return STATUS; end ADA_PTHREAD_SETPRIO; function ADA_PTHREAD_GETPRIO( PTHREAD : in CMA_TYPES.PTHREAD_T ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T; begin ADA_PTHREAD_TESTCANCEL; HANDLE := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD ); return HANDLE.PRIORITY; end ADA_PTHREAD_GETPRIO; ------------------------------------------------------------------------ -- -- "pthread_self()". - Retrieves the task record block that was -- allocated during the initial "pthread_ -- create()". The current task control block -- pointer is used as the key-value. -- ------------------------------------------------------------------------ function ADA_PTHREAD_SELF return CMA_TYPES.ADA_PTHREAD_T is function ADA_THD_GET_FROM_TASK_LIST( TCB_ID : in SYSTEM.ADDRESS ) return CMA_TYPES.ADA_PTHREAD_T; pragma INTERFACE( C, ADA_THD_GET_FROM_TASK_LIST ); HANDLE : CMA_TYPES.ADA_PTHREAD_T; use CMA_TYPES; begin HANDLE := ADA_THD_GET_FROM_TASK_LIST( CMA_TYPES.ADA_THD_GET_TASK_TCB_PTR ); if HANDLE = CMA_TYPES.NULL_ADA_PTHREAD_T then if CMA_TYPES.ADA_CURRENT_THREAD_TCB /= NULL_ADA_PTHREAD_T then HANDLE := ADA_CURRENT_THREAD_TCB; else HANDLE := ADA_MAIN_THREAD; end if; end if; return HANDLE; end ADA_PTHREAD_SELF; ------------------------------------------------------------------------ -- -- "pthread_testcancel()" - Checks cancelability by checking -- current state, and general -- cancelability. If the thread has -- been marked for cancellation and -- general cancellation is ON, then -- the thread is exited. -- -- General cancellation points are at -- calls to: -- -- pthread_setasynccancel(); -- pthread_testcancel(); -- pthread_delay_np(); -- pthread_join(); -- pthread_cond_wait(); -- pthread_cond_timedwait(); -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_TESTCANCEL is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; use CMA_TYPES; begin if HANDLE /= CMA_TYPES.NULL_ADA_PTHREAD_T then if HANDLE.STATE = CMA_TYPES.CANCELLED and HANDLE.GENERAL_CANCEL = CMA_TYPES.CANCEL_ON then HANDLE.STATE := CMA_TYPES.RUNNING; ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_PTHREAD_CANCEL_E ); end if; end if; end ADA_PTHREAD_TESTCANCEL; ------------------------------------------------------------------------ -- -- "pthread_keycreate()" - Creates a new thread key slot for the -- task. A separate key list is -- maintained for each task. The key -- value may be shared by multiple -- threads. -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_KEYCREATE( KEY : in CMA_TYPES.PTHREAD_KEY_T; DESTRUCTOR : in CMA_TYPES.PTHREAD_DESTRUCTOR_T ) is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; procedure ADA_THD_CREATE_KEY( ROOT : in SYSTEM.ADDRESS; KEY : in CMA_TYPES.PTHREAD_KEY_T; DESTRUCTOR : in CMA_TYPES.PTHREAD_DESTRUCTOR_T ); pragma INTERFACE( C, ADA_THD_CREATE_KEY ); begin ADA_TESTASYNCCANCEL; ADA_THD_CREATE_KEY( HANDLE.KEY_LIST'ADDRESS, KEY, DESTRUCTOR ); exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_PTHREAD_KEYCREATE; ------------------------------------------------------------------------ -- -- "pthread_getspecific()" - Gets the data associated with KEY. -- ------------------------------------------------------------------------ function ADA_PTHREAD_GETSPECIFIC( KEY : in CMA_TYPES.PTHREAD_KEY_T ) return CMA_TYPES.PTHREAD_ADDR_T is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; function ADA_THD_GET_KEY_VALUE( ROOT : in SYSTEM.ADDRESS; KEY : in CMA_TYPES.PTHREAD_KEY_T ) return CMA_TYPES.PTHREAD_ADDR_T; pragma INTERFACE( C, ADA_THD_GET_KEY_VALUE ); use CMA_TYPES; begin ADA_TESTASYNCCANCEL; return ADA_THD_GET_KEY_VALUE( HANDLE.KEY_LIST, KEY ); end ADA_PTHREAD_GETSPECIFIC; ------------------------------------------------------------------------ -- -- "pthread_setspecific()" - For the current task, sets the value -- of the KEY to VALUE. -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_SETSPECIFIC( KEY : in CMA_TYPES.PTHREAD_KEY_T; VALUE : in CMA_TYPES.PTHREAD_ADDR_T ) is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; procedure ADA_THD_SET_KEY_VALUE( ROOT : in SYSTEM.ADDRESS; KEY : in CMA_TYPES.PTHREAD_KEY_T; VALUE : in CMA_TYPES.PTHREAD_ADDR_T ); pragma INTERFACE( C, ADA_THD_SET_KEY_VALUE ); use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_THD_SET_KEY_VALUE( HANDLE.KEY_LIST, KEY, VALUE ); end ADA_PTHREAD_SETSPECIFIC; ------------------------------------------------------------------------ -- -- "pthread_attr_create()" -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_ATTR_CREATE( ATTR : in CMA_TYPES.PTHREAD_ATTR_T ) is ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; begin ADA_TESTASYNCCANCEL; ADA_ATTR := new CMA_TYPES.ADA_PTHREAD_ATTR_REC_T; ATTR.FIELD1 := CMA_TYPES.ADA_PTHREAD_ATTR_T_TO_CMA_T_ADDRESS( ADA_ATTR ); exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_PTHREAD_ATTR_CREATE; ------------------------------------------------------------------------ -- -- "pthread_mutexattr_create()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_MUTEXATTR_CREATE( ATTR : in CMA_TYPES.PTHREAD_MUTEXATTR_T ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_MUTEXATTR_T; STATUS : CMA_TYPES.C_INTEGER := 0; begin ADA_TESTASYNCCANCEL; ADA_ATTR := new CMA_TYPES.ADA_MUTEXATTR_REC_T; ATTR.FIELD1 := CMA_TYPES.ADA_MUTEXATTR_T_TO_CMA_T_ADDRESS( ADA_ATTR ); return STATUS; exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_PTHREAD_MUTEXATTR_CREATE; ------------------------------------------------------------------------ -- -- "pthread_mutexattr_setkind_np()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_MUTEXATTR_SETKIND_NP( ATTR : in CMA_TYPES.PTHREAD_MUTEXATTR_T; KIND : in CMA_TYPES.MUTEX_KIND_T ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_MUTEXATTR_T; STATUS : CMA_TYPES.C_INTEGER := 0; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_MUTEXATTR( ATTR ); ADA_ATTR.KIND := KIND; return STATUS; end ADA_PTHREAD_MUTEXATTR_SETKIND_NP; ------------------------------------------------------------------------ -- -- "pthread_mutexattr_setnochecking_np()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_MUTEXATTR_DISABLECHECKS_NP( ATTR : in CMA_TYPES.PTHREAD_MUTEXATTR_T ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_MUTEXATTR_T; STATUS : CMA_TYPES.C_INTEGER := 0; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_MUTEXATTR( ATTR ); ADA_ATTR.FULL_CHECKING := FALSE; return STATUS; end ADA_PTHREAD_MUTEXATTR_DISABLECHECKS_NP; ------------------------------------------------------------------------ -- -- "pthread_condattr_create()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_CONDATTR_CREATE( ATTR : in CMA_TYPES.PTHREAD_CONDATTR_T ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_CONDATTR_T; STATUS : CMA_TYPES.C_INTEGER := 0; begin ADA_TESTASYNCCANCEL; ADA_ATTR := new CMA_TYPES.ADA_CONDATTR_REC_T; ATTR.FIELD1 := CMA_TYPES.ADA_CONDATTR_T_TO_CMA_T_ADDRESS( ADA_ATTR ); return STATUS; exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_PTHREAD_CONDATTR_CREATE; ------------------------------------------------------------------------ -- -- "pthread_attr_setprio()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_SETPRIO( ATTR : in CMA_TYPES.PTHREAD_ATTR_T; PRIORITY : in CMA_TYPES.C_INTEGER ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; ANSWER : CMA_TYPES.C_INTEGER := 0; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); ADA_ATTR.PRIORITY := PRIORITY; return ANSWER; end ADA_PTHREAD_ATTR_SETPRIO; ------------------------------------------------------------------------ -- -- "pthread_attr_getprio()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_GETPRIO( ATTR : in CMA_TYPES.PTHREAD_ATTR_T ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; ANSWER : CMA_TYPES.C_INTEGER := -1; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); ANSWER := ADA_ATTR.PRIORITY; return ANSWER; end ADA_PTHREAD_ATTR_GETPRIO; ------------------------------------------------------------------------ -- -- "pthread_attr_getsched()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_GETSCHED( ATTR : in CMA_TYPES.PTHREAD_ATTR_T ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; ANSWER : CMA_TYPES.C_INTEGER := -1; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); ANSWER := ADA_ATTR.SCHED; return ANSWER; end ADA_PTHREAD_ATTR_GETSCHED; ------------------------------------------------------------------------ -- -- "pthread_attr_getinheritsched()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_GETINHERITSCHED( ATTR : in CMA_TYPES.PTHREAD_ATTR_T ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; ANSWER : CMA_TYPES.C_INTEGER := -1; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); ANSWER := ADA_ATTR.INHERIT; return ANSWER; end ADA_PTHREAD_ATTR_GETINHERITSCHED; ------------------------------------------------------------------------ -- -- "pthread_attr_getinheritsched()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_GETSTACKSIZE( ATTR : in CMA_TYPES.PTHREAD_ATTR_T ) return CMA_TYPES.C_INTEGER is ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; ANSWER : CMA_TYPES.C_INTEGER := -1; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); ANSWER := ADA_ATTR.STACK_SIZE; return ANSWER; end ADA_PTHREAD_ATTR_GETSTACKSIZE; ------------------------------------------------------------------------ -- -- "pthread_attr_delete()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_DELETE( ATTR : in CMA_TYPES.PTHREAD_ATTR_T ) return CMA_TYPES.C_INTEGER is ANSWER : CMA_TYPES.C_INTEGER := 0; ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); CMA_TYPES.FREE( ADA_ATTR ); return ANSWER; end ADA_PTHREAD_ATTR_DELETE; ------------------------------------------------------------------------ -- -- "pthread_mutexattr_delete()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_MUTEXATTR_DELETE( ATTR : in CMA_TYPES.PTHREAD_MUTEXATTR_T ) return CMA_TYPES.C_INTEGER is ANSWER : CMA_TYPES.C_INTEGER := 0; ADA_ATTR : CMA_TYPES.ADA_MUTEXATTR_T; use CMA_TYPES; begin ADA_ATTR := CMA_TYPES.GET_ADA_MUTEXATTR( ATTR ); CMA_TYPES.FREE( ADA_ATTR ); ADA_TESTASYNCCANCEL; return ANSWER; end ADA_PTHREAD_MUTEXATTR_DELETE; ------------------------------------------------------------------------ -- -- "pthread_condattr_delete()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_CONDATTR_DELETE( ATTR : in CMA_TYPES.PTHREAD_CONDATTR_T ) return CMA_TYPES.C_INTEGER is ANSWER : CMA_TYPES.C_INTEGER := 0; ADA_ATTR : CMA_TYPES.ADA_CONDATTR_T; use CMA_TYPES; begin ADA_ATTR := CMA_TYPES.GET_ADA_COND_ATTR( ATTR ); CMA_TYPES.FREE( ADA_ATTR ); ADA_TESTASYNCCANCEL; return ANSWER; end ADA_PTHREAD_CONDATTR_DELETE; ------------------------------------------------------------------------ -- -- "pthread_attr_setsched()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_SETSCHED( ATTR : in CMA_TYPES.PTHREAD_ATTR_T; SCHED : in CMA_TYPES.C_INTEGER ) return CMA_TYPES.C_INTEGER is ANSWER : CMA_TYPES.C_INTEGER := 0; ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); ADA_ATTR.SCHED := SCHED; return ANSWER; end ADA_PTHREAD_ATTR_SETSCHED; ------------------------------------------------------------------------ -- -- "pthread_attr_setstacksize()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_SETSTACKSIZE( ATTR : in CMA_TYPES.PTHREAD_ATTR_T; STACKSIZE : in CMA_TYPES.LONG ) return CMA_TYPES.C_INTEGER is ANSWER : CMA_TYPES.C_INTEGER := 0; ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); ADA_ATTR.STACK_SIZE := STACKSIZE; return ANSWER; end ADA_PTHREAD_ATTR_SETSTACKSIZE; ------------------------------------------------------------------------ -- -- "pthread_attr_setinheritsched()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_ATTR_SETINHERITSCHED( ATTR : in CMA_TYPES.PTHREAD_ATTR_T; SETINHERIT : in CMA_TYPES.C_INTEGER ) return CMA_TYPES.C_INTEGER is ANSWER : CMA_TYPES.C_INTEGER := 0; ADA_ATTR : CMA_TYPES.ADA_PTHREAD_ATTR_T; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_PTHREAD_ATTR( ATTR ); ADA_ATTR.INHERIT := SETINHERIT; return ANSWER; end ADA_PTHREAD_ATTR_SETINHERITSCHED; ------------------------------------------------------------------------ -- -- Checks to see if the input "key" is valid -- ------------------------------------------------------------------------ function ADA_THD_IS_KEY_VALID( KEY : in CMA_TYPES.PTHREAD_KEY_T ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; FOUND : CMA_TYPES.C_INTEGER := 0; function ADA_THD_CHECK_KEY( ROOT : in SYSTEM.ADDRESS; KEY : in CMA_TYPES.PTHREAD_KEY_T ) return CMA_TYPES.C_INTEGER; pragma INTERFACE( C, ADA_THD_CHECK_KEY ); begin return ADA_THD_CHECK_KEY( HANDLE.KEY_LIST, KEY ); end ADA_THD_IS_KEY_VALID; function IS_MUTEX_NULL( MUTEX : in CMA_TYPES.ADA_PTHREAD_MUTEX_T ) return BOOLEAN is use CMA_TYPES; begin return MUTEX = CMA_TYPES.NULL_ADA_PTHREAD_MUTEX_T; end IS_MUTEX_NULL; ------------------------------------------------------------------------ -- -- Determines if I'm the owner of a mutex. -- ------------------------------------------------------------------------ function DO_I_OWN_MUTEX( MUTEX : in CMA_TYPES.ADA_PTHREAD_MUTEX_T ) return BOOLEAN is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; ANSWER : BOOLEAN := FALSE; use CMA_TYPES; begin if IS_MUTEX_NULL( MUTEX ) or MUTEX.OWNER = HANDLE then ANSWER := TRUE; end if; return ANSWER; end DO_I_OWN_MUTEX; ------------------------------------------------------------------------ -- -- "pthread_mutex_init()" - Creates a mutex object. -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_MUTEX_INIT( PMUTEX : in CMA_TYPES.PTHREAD_MUTEX_T; ATTR : in CMA_TYPES.PTHREAD_MUTEXATTR_T ) is HANDLE : CMA_TYPES.ADA_PTHREAD_MUTEX_T; ADA_ATTR : CMA_TYPES.ADA_MUTEXATTR_T; I : INTEGER; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; ADA_ATTR := CMA_TYPES.GET_ADA_MUTEXATTR( ATTR ); HANDLE := new CMA_TYPES.ADA_MUTEX_T_HANDLE; I := HANDLE.INT_LOCK'STORAGE_SIZE; if ADA_ATTR = CMA_TYPES.MUTEXATTR_DEFAULT then HANDLE.KIND := CMA_TYPES.MUTEX_FAST_NP; else HANDLE.KIND := ADA_ATTR.KIND; HANDLE.FULL_CHECKING := ADA_ATTR.FULL_CHECKING; end if; -- HANDLE.WAITERS := 0; -- HANDLE.NEST_CNT := 0; -- HANDLE.LOCK := 0; -- HANDLE.EVENT := 1; HANDLE.STATE := CMA_TYPES.UNLOCK; HANDLE.SEM := new DCE_ADA_SEMAPHORE.SEMAPHORE_TASK_TYPE; PMUTEX.FIELD1 := CMA_TYPES.ADA_PTHREAD_MUTEX_T_TO_CMA_T_ADDRESS( HANDLE ); exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_PTHREAD_MUTEX_INIT; procedure VALIDATE_MUTEX_LOCK( MUTEX : in CMA_TYPES.ADA_PTHREAD_MUTEX_T; OWNER : in BOOLEAN; NULL_M : in BOOLEAN ) is use CMA_TYPES; begin if OWNER and not NULL_M then if MUTEX.KIND = CMA_TYPES.MUTEX_NONRECURSIVE_NP then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_EDEADLK_E ); elsif MUTEX.KIND = CMA_TYPES.MUTEX_FAST_NP then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_USE_ERROR_E ); end if; end if; end VALIDATE_MUTEX_LOCK; ------------------------------------------------------------------------ -- -- Determines if the current mutex is valid -- ------------------------------------------------------------------------ procedure VALIDATE_MUTEX( MUTEX : in CMA_TYPES.ADA_PTHREAD_MUTEX_T; OP : in CMA_TYPES.MUTEX_STATE_T ) is OWNER : BOOLEAN; NULL_M : BOOLEAN; use CMA_TYPES; begin if not MUTEX.FULL_CHECKING then return; end if; OWNER := DO_I_OWN_MUTEX( MUTEX ); NULL_M := IS_MUTEX_NULL( MUTEX ); if MUTEX = CMA_TYPES.NULL_ADA_PTHREAD_MUTEX_T then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_INVALID_OBJ_E ); elsif not MUTEX.SEM'CALLABLE then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_INVALID_OBJ_E ); elsif MUTEX.SEM'TERMINATED then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_INVALID_OBJ_E ); end if; case OP is when CMA_TYPES.LOCK => VALIDATE_MUTEX_LOCK( MUTEX, OWNER, NULL_M ); when CMA_TYPES.UNLOCK => if not OWNER and MUTEX.STATE = CMA_TYPES.LOCK then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_USE_ERROR_E ); end if; when CMA_TYPES.DESTROY => if MUTEX.STATE = CMA_TYPES.LOCK then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_EBUSY_E ); end if; when OTHERS => NULL; end case; end VALIDATE_MUTEX; ------------------------------------------------------------------------ -- -- Unlocks a mutex object -- ------------------------------------------------------------------------ procedure UNLOCK_MUTEX( MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T ) is use CMA_TYPES; begin case MUTEX.KIND is when CMA_TYPES.MUTEX_FAST_NP => MUTEX.INT_LOCK.LOCK; ADA_THD_UNSET32( MUTEX.LOCK'ADDRESS ); MUTEX.OWNER := CMA_TYPES.NULL_ADA_PTHREAD_T; MUTEX.INT_LOCK.UNLOCK; if ADA_THD_TEST_AND_SET32( MUTEX.EVENT'ADDRESS ) = 0 then MUTEX.SEM.WAKE_ONE; end if; when CMA_TYPES.MUTEX_RECURSIVE_NP | CMA_TYPES.MUTEX_NONRECURSIVE_NP => MUTEX.INT_LOCK.LOCK; if MUTEX.KIND = CMA_TYPES.MUTEX_RECURSIVE_NP then MUTEX.NEST_CNT := MUTEX.NEST_CNT - 1; end if; if MUTEX.KIND /= CMA_TYPES.MUTEX_RECURSIVE_NP or MUTEX.NEST_CNT = 0 then MUTEX.OWNER := CMA_TYPES.NULL_ADA_PTHREAD_T; if ADA_THD_TEST_AND_SET32( MUTEX.WAITERS'ADDRESS ) = 0 then MUTEX.SEM.WAKE_ONE; end if; end if; MUTEX.INT_LOCK.UNLOCK; end case; MUTEX.INT_LOCK.LOCK; MUTEX.STATE := CMA_TYPES.UNLOCK; MUTEX.INT_LOCK.UNLOCK; end UNLOCK_MUTEX; ------------------------------------------------------------------------ -- -- "pthread_mutex_unlock()" - Unlocks a mutex object. -- ------------------------------------------------------------------------ function ADA_PTHREAD_MUTEX_UNLOCK( PMUTEX : in CMA_TYPES.PTHREAD_MUTEX_T ) return CMA_TYPES.C_INTEGER is MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; MUTEX := CMA_TYPES.GET_ADA_MUTEX_HANDLE( PMUTEX ); VALIDATE_MUTEX( MUTEX, CMA_TYPES.UNLOCK ); UNLOCK_MUTEX( MUTEX ); return 0; end ADA_PTHREAD_MUTEX_UNLOCK; ------------------------------------------------------------------------ -- -- Locks a Mutex Object -- ------------------------------------------------------------------------ procedure LOCK_MUTEX( MUTEX : in CMA_TYPES.ADA_PTHREAD_MUTEX_T ) is RECURSIVE : BOOLEAN; use CMA_TYPES; begin case MUTEX.KIND is when CMA_TYPES.MUTEX_FAST_NP => if ADA_THD_TEST_AND_SET32( MUTEX.LOCK'ADDRESS ) /= 0 then loop ADA_THD_UNSET32( MUTEX.EVENT'ADDRESS ); if ADA_THD_TEST_AND_SET32( MUTEX.LOCK'ADDRESS ) = 0 then exit; end if; MUTEX.SEM.WAIT; end loop; end if; MUTEX.INT_LOCK.LOCK; MUTEX.OWNER := ADA_PTHREAD_SELF; MUTEX.INT_LOCK.UNLOCK; when CMA_TYPES.MUTEX_RECURSIVE_NP | CMA_TYPES.MUTEX_NONRECURSIVE_NP => if MUTEX.KIND = CMA_TYPES.MUTEX_RECURSIVE_NP then RECURSIVE := TRUE; else RECURSIVE := FALSE; end if; MUTEX.INT_LOCK.LOCK; if RECURSIVE and DO_I_OWN_MUTEX( MUTEX ) then NULL; elsif not RECURSIVE and MUTEX.OWNER = ADA_PTHREAD_SELF then TEXT_IO.PUT_LINE( "Can't re-Lock non-recursive Mutex" ); MUTEX.INT_LOCK.UNLOCK; return; else while TRUE loop ADA_THD_UNSET32( MUTEX.WAITERS'ADDRESS ); if MUTEX.OWNER = CMA_TYPES.NULL_ADA_PTHREAD_T then exit; end if; MUTEX.INT_LOCK.UNLOCK; MUTEX.SEM.WAIT; MUTEX.INT_LOCK.LOCK; end loop; end if; if RECURSIVE then MUTEX.NEST_CNT := MUTEX.NEST_CNT + 1; end if; MUTEX.OWNER := ADA_PTHREAD_SELF; MUTEX.INT_LOCK.UNLOCK; when OTHERS => NULL; end case; MUTEX.INT_LOCK.LOCK; MUTEX.STATE := CMA_TYPES.LOCK; MUTEX.INT_LOCK.UNLOCK; end LOCK_MUTEX; ------------------------------------------------------------------------ -- -- "pthread_mutex_lock()" - Locks a mutex object -- ------------------------------------------------------------------------ function ADA_PTHREAD_MUTEX_LOCK( PMUTEX : in CMA_TYPES.PTHREAD_MUTEX_T ) return CMA_TYPES.C_INTEGER is MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T; RECURSIVE : BOOLEAN := FALSE; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; MUTEX := CMA_TYPES.GET_ADA_MUTEX_HANDLE( PMUTEX ); VALIDATE_MUTEX( MUTEX, CMA_TYPES.LOCK ); LOCK_MUTEX( MUTEX ); return 0; end ADA_PTHREAD_MUTEX_LOCK; ------------------------------------------------------------------------ -- -- Tests to see if a mutex is locked -- ------------------------------------------------------------------------ function TRY_MUTEX_LOCK( MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T ) return CMA_TYPES.C_INTEGER is ME : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; ANSWER : CMA_TYPES.C_INTEGER := 1; use CMA_TYPES; begin if ADA_THD_TEST_AND_SET32( MUTEX.LOCK'ADDRESS ) /= 0 then case MUTEX.KIND is when CMA_TYPES.MUTEX_NONRECURSIVE_NP => MUTEX.INT_LOCK.LOCK; if MUTEX.OWNER = NULL_ADA_PTHREAD_T then MUTEX.OWNER := ME; else ANSWER := 0; end if; MUTEX.INT_LOCK.UNLOCK; when CMA_TYPES.MUTEX_RECURSIVE_NP => MUTEX.INT_LOCK.LOCK; if DO_I_OWN_MUTEX( MUTEX ) then MUTEX.NEST_CNT := MUTEX.NEST_CNT + 1; MUTEX.OWNER := ME; else ANSWER := 0; end if; MUTEX.INT_LOCK.UNLOCK; when CMA_TYPES.MUTEX_FAST_NP => ANSWER := 0; end case; end if; return ANSWER; end TRY_MUTEX_LOCK; ------------------------------------------------------------------------ -- -- "pthread_mutex_destroy()" - Deletes a mutex -- ------------------------------------------------------------------------ function ADA_PTHREAD_MUTEX_DESTROY( PMUTEX : in CMA_TYPES.PTHREAD_MUTEX_T ) return CMA_TYPES.C_INTEGER is MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T; use CMA_TYPES; begin MUTEX := CMA_TYPES.GET_ADA_MUTEX_HANDLE( PMUTEX ); VALIDATE_MUTEX( MUTEX, CMA_TYPES.DESTROY ); MUTEX.INT_LOCK.STOP; -- Delete internal lock MUTEX.SEM.STOP; -- Delete mutex PMUTEX.FIELD1 := CMA_TYPES.NULL_CMA_T_ADDRESS; DCE_ADA_SEMAPHORE.FREE( MUTEX.SEM ); CMA_TYPES.FREE( MUTEX ); ADA_TESTASYNCCANCEL; return 0; end ADA_PTHREAD_MUTEX_DESTROY; ------------------------------------------------------------------------ -- -- "pthread_mutex_trylock()" - Locks a mutex object -- ------------------------------------------------------------------------ function ADA_PTHREAD_MUTEX_TRYLOCK( PMUTEX : in CMA_TYPES.PTHREAD_MUTEX_T ) return CMA_TYPES.C_INTEGER is MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T; ANSWER : CMA_TYPES.C_INTEGER := -1; use CMA_TYPES; begin ADA_TESTASYNCCANCEL; MUTEX := CMA_TYPES.GET_ADA_MUTEX_HANDLE( PMUTEX ); VALIDATE_MUTEX( MUTEX, CMA_TYPES.LOCK ); ANSWER := TRY_MUTEX_LOCK( MUTEX ); return ANSWER; end ADA_PTHREAD_MUTEX_TRYLOCK; ------------------------------------------------------------------------ -- -- Determines if a condition variable is valid. -- ------------------------------------------------------------------------ function VALID_PTHREAD_COND_T( HANDLE : in CMA_TYPES.ADA_PTHREAD_COND_T ) return BOOLEAN is ANSWER : BOOLEAN := TRUE; use CMA_TYPES; begin if HANDLE = CMA_TYPES.NULL_ADA_PTHREAD_COND_T then ANSWER := FALSE; end if; return ANSWER; end VALID_PTHREAD_COND_T; ------------------------------------------------------------------------ -- -- "pthread_cond_init()" - Creates a condition variable object. -- ------------------------------------------------------------------------ procedure ADA_PTHREAD_COND_INIT( PCOND : in CMA_TYPES.PTHREAD_COND_T; ATTR : in CMA_TYPES.PTHREAD_CONDATTR_T ) is HANDLE : CMA_TYPES.ADA_PTHREAD_COND_T; begin ADA_TESTASYNCCANCEL; HANDLE := new CMA_TYPES.ADA_COND_T_HANDLE; HANDLE.SEM := new DCE_ADA_SEMAPHORE.SEMAPHORE_TASK_TYPE; PCOND.FIELD1 := CMA_TYPES.ADA_PTHREAD_COND_T_TO_CMA_T_ADDRESS( HANDLE ); exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_PTHREAD_COND_INIT; ------------------------------------------------------------------------ -- -- "pthread_cond_signal()" - Signals a condition variable object. -- ------------------------------------------------------------------------ function ADA_PTHREAD_COND_SIGNAL( PCOND : in CMA_TYPES.PTHREAD_COND_T ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_COND_T; ANSWER : CMA_TYPES.C_INTEGER := 0; begin ADA_TESTASYNCCANCEL; HANDLE := CMA_TYPES.GET_ADA_COND_HANDLE( PCOND ); if VALID_PTHREAD_COND_T( HANDLE ) then HANDLE.SEM.WAKE_ONE; else ANSWER := -1; end if; return ANSWER; end ADA_PTHREAD_COND_SIGNAL; ------------------------------------------------------------------------ -- -- "pthread_cond_broadcast()" - Broadcasts to a condition variable -- object. -- ------------------------------------------------------------------------ function ADA_PTHREAD_COND_BROADCAST( PCOND : in CMA_TYPES.PTHREAD_COND_T ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_COND_T; ANSWER : CMA_TYPES.C_INTEGER := 0; begin ADA_TESTASYNCCANCEL; HANDLE := CMA_TYPES.GET_ADA_COND_HANDLE( PCOND ); if VALID_PTHREAD_COND_T( HANDLE ) then HANDLE.SEM.WAKE_ALL; else ANSWER := -1; end if; return ANSWER; end ADA_PTHREAD_COND_BROADCAST; ------------------------------------------------------------------------ -- -- "pthread_cond_wait()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_COND_WAIT( PCOND : in CMA_TYPES.PTHREAD_COND_T; PMUTEX : in CMA_TYPES.PTHREAD_MUTEX_T ) return CMA_TYPES.C_INTEGER is ME : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; HANDLE : CMA_TYPES.ADA_PTHREAD_COND_T; MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T; ANSWER : CMA_TYPES.C_INTEGER := 0; use CMA_TYPES; begin ADA_PTHREAD_TESTCANCEL; HANDLE := CMA_TYPES.GET_ADA_COND_HANDLE( PCOND ); if VALID_PTHREAD_COND_T( HANDLE ) then MUTEX := CMA_TYPES.GET_ADA_MUTEX_HANDLE( PMUTEX ); HANDLE.INT_LOCK.LOCK; HANDLE.MUTEX := MUTEX; HANDLE.LOCK_CNT := HANDLE.LOCK_CNT + 1; HANDLE.INT_LOCK.UNLOCK; ME.INT_LOCK.LOCK; ME.CV := HANDLE; ME.INT_LOCK.UNLOCK; UNLOCK_MUTEX( MUTEX ); -- Unlock the mutex HANDLE.SEM.WAIT; -- Wait on the CV LOCK_MUTEX( MUTEX ); -- Lock the mutex HANDLE.INT_LOCK.LOCK; HANDLE.LOCK_CNT := HANDLE.LOCK_CNT - 1; HANDLE.INT_LOCK.UNLOCK; ADA_PTHREAD_TESTCANCEL; ME.INT_LOCK.LOCK; ME.CV := CMA_TYPES.NULL_ADA_PTHREAD_COND_T; ME.INT_LOCK.UNLOCK; else ANSWER := -1; end if; return ANSWER; end ADA_PTHREAD_COND_WAIT; ------------------------------------------------------------------------ -- -- "pthread_cond_timedwait()" -- ------------------------------------------------------------------------ function ADA_PTHREAD_COND_TIMEDWAIT( PCOND : in CMA_TYPES.PTHREAD_COND_T; PMUTEX : in CMA_TYPES.PTHREAD_MUTEX_T; ABSTIME : in CMA_TYPES.TIME_SPEC_P ) return CMA_TYPES.C_INTEGER is TIME_IN : CALENDAR.TIME := CALENDAR.CLOCK; ME : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; HANDLE : CMA_TYPES.ADA_PTHREAD_COND_T; MUTEX : CMA_TYPES.ADA_PTHREAD_MUTEX_T; TDELAY : CMA_TYPES.TIME_SPEC; WAIT_T : DURATION; ANSWER : CMA_TYPES.C_INTEGER := 0; T_FLAG : CMA_TYPES.C_INTEGER; function ADA_THD_EXPIRATION_TO_DELAY( TS : in CMA_TYPES.TIME_SPEC_P; TD : in SYSTEM.ADDRESS ) return CMA_TYPES.C_INTEGER; pragma INTERFACE( C, ADA_THD_EXPIRATION_TO_DELAY ); function ADA_THD_LONG_TO_FLOAT( VAL : CMA_TYPES.LONG ) return FLOAT; pragma INTERFACE( C, ADA_THD_LONG_TO_FLOAT ); use CALENDAR; begin ADA_PTHREAD_TESTCANCEL; HANDLE := CMA_TYPES.GET_ADA_COND_HANDLE( PCOND ); if VALID_PTHREAD_COND_T( HANDLE ) then MUTEX := CMA_TYPES.GET_ADA_MUTEX_HANDLE( PMUTEX ); HANDLE.INT_LOCK.LOCK; HANDLE.MUTEX := MUTEX; HANDLE.LOCK_CNT := HANDLE.LOCK_CNT + 1; HANDLE.INT_LOCK.UNLOCK; T_FLAG := ADA_THD_EXPIRATION_TO_DELAY( ABSTIME, TDELAY'ADDRESS ); if T_FLAG = 0 then WAIT_T := DURATION( ADA_THD_LONG_TO_FLOAT( TDELAY.TV_SEC ) ) + DURATION( ADA_THD_LONG_TO_FLOAT( TDELAY.TV_NSEC )/1.0e+9 ); TIME_IN := TIME_IN + WAIT_T; -- When alarm is to expire ME.INT_LOCK.LOCK; ME.CV := HANDLE; ME.INT_LOCK.UNLOCK; UNLOCK_MUTEX( MUTEX ); -- Unlock the mutex select HANDLE.SEM.TIMED_WAIT( TIME_IN ); else delay WAIT_T; end select; LOCK_MUTEX( MUTEX ); -- Lock the mutex ME.INT_LOCK.LOCK; ME.CV := CMA_TYPES.NULL_ADA_PTHREAD_COND_T; ME.INT_LOCK.UNLOCK; ADA_PTHREAD_TESTCANCEL; else ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_TIMED_OUT_E ); end if; HANDLE.INT_LOCK.LOCK; HANDLE.LOCK_CNT := HANDLE.LOCK_CNT - 1; HANDLE.INT_LOCK.UNLOCK; else ANSWER := -1; end if; return ANSWER; end ADA_PTHREAD_COND_TIMEDWAIT; ------------------------------------------------------------------------ -- -- "pthread_cond_destroy()" - Deletes a condition variable -- ------------------------------------------------------------------------ function ADA_PTHREAD_COND_DESTROY( PCOND : in CMA_TYPES.PTHREAD_COND_T ) return CMA_TYPES.C_INTEGER is COND : CMA_TYPES.ADA_PTHREAD_COND_T; ANSWER : CMA_TYPES.C_INTEGER := 0; use CMA_TYPES; begin COND := CMA_TYPES.GET_ADA_COND_HANDLE( PCOND ); if VALID_PTHREAD_COND_T( COND ) then if COND.LOCK_CNT /= 0 then ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_EBUSY_E ); end if; COND.SEM.STOP; DCE_ADA_SEMAPHORE.FREE( COND.SEM ); CMA_TYPES.FREE( COND ); PCOND.FIELD1 := CMA_TYPES.NULL_CMA_T_ADDRESS; else ANSWER := -1; end if; ADA_TESTASYNCCANCEL; return ANSWER; end ADA_PTHREAD_COND_DESTROY; ------------------------------------------------------------------------ -- -- Returns the CMA_THREAD_TCB member of the task control record -- ------------------------------------------------------------------------ function ADA_GET_SELF_CMA_TCB return SYSTEM.ADDRESS is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; TCB : SYSTEM.ADDRESS := SYSTEM.NULL_ADDRESS; use CMA_TYPES; begin if HANDLE /= CMA_TYPES.NULL_ADA_PTHREAD_T then TCB := HANDLE.CMA_THREAD_TCB; end if; return TCB; end ADA_GET_SELF_CMA_TCB; function ADA_THD_GET_CMA_TCB( HANDLE : CMA_TYPES.ADA_PTHREAD_T ) return SYSTEM.ADDRESS is TCB : SYSTEM.ADDRESS := SYSTEM.NULL_ADDRESS; use CMA_TYPES; begin if HANDLE /= CMA_TYPES.NULL_ADA_PTHREAD_T then TCB := HANDLE.CMA_THREAD_TCB; end if; return TCB; end ADA_THD_GET_CMA_TCB; ------------------------------------------------------------------------ -- -- Returns the number of cleanup handlers pushed onto the threads stack -- ------------------------------------------------------------------------ function ADA_THREAD_HANDLER_COUNT return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; CNT : CMA_TYPES.C_INTEGER := 0; begin HANDLE.INT_LOCK.LOCK; CNT := HANDLE.CLEANUP_HNDLRS; HANDLE.INT_LOCK.UNLOCK; return CNT; end ADA_THREAD_HANDLER_COUNT; ------------------------------------------------------------------------ -- -- Sets the errno value for the current thread. -- ------------------------------------------------------------------------ function ADA_THD_SET_ERRNO( ERRNO : in CMA_TYPES.C_INTEGER ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; use CMA_TYPES; begin if( HANDLE /= CMA_TYPES.NULL_ADA_PTHREAD_T ) then HANDLE.ERRNO := ERRNO; end if; return ERRNO; end ADA_THD_SET_ERRNO; function ADA_THD_GET_PTHREAD_ERRNO return SYSTEM.ADDRESS; pragma EXPORT( C, ADA_THD_GET_PTHREAD_ERRNO ); ------------------------------------------------------------------------ -- -- Returns the address of the task's errno value -- ------------------------------------------------------------------------ function ADA_THD_GET_PTHREAD_ERRNO return SYSTEM.ADDRESS is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; begin return HANDLE.ERRNO'ADDRESS; end ADA_THD_GET_PTHREAD_ERRNO; function ADA_GET_EXIT_STATUS return CMA_TYPES.PTHREAD_ADDR_T is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; begin return HANDLE.EXIT_STATUS; end ADA_GET_EXIT_STATUS; function ADA_PTHREAD_GETUNIQUE_NP( PTHREAD : in CMA_TYPES.PTHREAD_T ) return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T; begin ADA_TESTASYNCCANCEL; HANDLE := CMA_TYPES.GET_ADA_THREAD_HANDLE( PTHREAD ); return HANDLE.UNIQUE_ID; end ADA_PTHREAD_GETUNIQUE_NP; procedure ADA_THD_LOCK_INT_MUTEX( MUTEX : in INT_LOCK_HANDLE ) is use CMA_TYPES; begin if MUTEX.OWNER = CMA_TYPES.NULL_ADA_PTHREAD_T or MUTEX.OWNER = ADA_PTHREAD_SELF then NULL; else while TRUE loop ADA_THD_UNSET32( MUTEX.WAITERS'ADDRESS ); if MUTEX.OWNER = CMA_TYPES.NULL_ADA_PTHREAD_T then exit; end if; MUTEX.SEM.WAIT; end loop; end if; MUTEX.NEST_CNT := MUTEX.NEST_CNT + 1; MUTEX.OWNER := ADA_PTHREAD_SELF; end ADA_THD_LOCK_INT_MUTEX; procedure ADA_THD_UNLOCK_INT_MUTEX( MUTEX : in INT_LOCK_HANDLE ) is use CMA_TYPES; begin MUTEX.NEST_CNT := MUTEX.NEST_CNT - 1; ADA_THD_UNSET32( MUTEX.EVENT'ADDRESS ); if MUTEX.NEST_CNT = 0 then MUTEX.OWNER := CMA_TYPES.NULL_ADA_PTHREAD_T; if ADA_THD_TEST_AND_SET32( MUTEX.WAITERS'ADDRESS ) = 0 then MUTEX.SEM.WAKE_ONE; end if; end if; end ADA_THD_UNLOCK_INT_MUTEX; function ADA_THD_CREATE_INT_MUTEX return INT_LOCK_HANDLE is LOCK_PTR : INT_LOCK_HANDLE; begin LOCK_PTR := new INTERNAL_LOCK_RECORD; LOCK_PTR.OWNER := CMA_TYPES.NULL_ADA_PTHREAD_T; LOCK_PTR.WAITERS := 0; LOCK_PTR.NEST_CNT := 0; LOCK_PTR.LOCK := 0; LOCK_PTR.EVENT := 1; return LOCK_PTR; exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( CMA_TYPES.ADA_NO_MEMORY_E ); end ADA_THD_CREATE_INT_MUTEX; procedure ADA_THD_SET_SELECT_STATE ( STATE : in CMA_TYPES.C_INTEGER ) is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; begin if STATE = 0 then HANDLE.SELECT_WAIT := FALSE; else HANDLE.SELECT_WAIT := TRUE; end if; end ADA_THD_SET_SELECT_STATE; function ADA_THD_CANCELLED return CMA_TYPES.C_INTEGER is HANDLE : CMA_TYPES.ADA_PTHREAD_T := ADA_PTHREAD_SELF; ANS : CMA_TYPES.C_INTEGER := 0; use CMA_TYPES; begin if HANDLE.STATE = CMA_TYPES.CANCELLED then ANS := 1; end if; return ANS; end ADA_THD_CANCELLED; end DCE_THREADS;