----------------------------------------------------------------------- -- Howard Eng 2/94-- -- Unixpros, Inc. -- -- -- -- This package defines common data types that map between "cma.h" -- -- and the Ada environment. It also defines task body's that are -- -- used to support pthreads. -- ----------------------------------------------------------------------- with CALENDAR; with SYSTEM; with TEXT_IO; with SYSTEM_ENVIRONMENT; package body CMA_TYPES is use SYSTEM; procedure ADA_THD_RAISE_EXCEPTION( EXC : in ADA_PTHREAD_EXC_T ); pragma INTERFACE( C, ADA_THD_RAISE_EXCEPTION ); ------------------------------------------------------------------------ -- -- Frees an Ada Pthread structure. The handle's task ID and TCB are -- set to NULL to indicate that they were once valid, but has since -- been detached. -- ------------------------------------------------------------------------ procedure FREE_PTHREAD_HANDLE( HANDLE : in ADA_PTHREAD_T ) is procedure ADA_THD_C_FREE( ADDR : in SYSTEM.ADDRESS ); pragma INTERFACE( C, ADA_THD_C_FREE ); procedure ADA_THD_RELEASE_CMA_TCB( ADDR : in SYSTEM.ADDRESS ); pragma INTERFACE( C, ADA_THD_RELEASE_CMA_TCB ); begin FREE( HANDLE.TASK_ID ); HANDLE.TASK_ID := NULL_THREAD; if HANDLE.JOIN_CV /= NULL_INT_CV then FREE( HANDLE.JOIN_CV ); HANDLE.JOIN_CV := NULL_INT_CV; end if; if HANDLE.WAIT_CV /= NULL_INT_CV then FREE( HANDLE.WAIT_CV ); HANDLE.WAIT_CV := NULL_INT_CV; end if; if HANDLE.WAIT_MUTEX /= NULL_INT_LOCK then FREE( HANDLE.WAIT_MUTEX ); HANDLE.WAIT_MUTEX := NULL_INT_LOCK; end if; ADA_THD_RELEASE_CMA_TCB( HANDLE.CMA_THREAD_TCB ); HANDLE.CMA_THREAD_TCB := SYSTEM.NULL_ADDRESS; end FREE_PTHREAD_HANDLE; ------------------------------------------------------------------------ -- -- Frees an Ada Pthread structure. The internal lock is locked before -- the actual freeing. -- ------------------------------------------------------------------------ procedure FREE_ADA_PTHREAD_T( HANDLE : in ADA_PTHREAD_T ) is begin HANDLE.INT_LOCK.LOCK; FREE_PTHREAD_HANDLE( HANDLE ); HANDLE.INT_LOCK.UNLOCK; end FREE_ADA_PTHREAD_T; ------------------------------------------------------------------------ -- -- Task used to execute a thread procedure -- ------------------------------------------------------------------------ task body CMA_THREAD_TASK_TYPE is ENTRY_POINT : PTHREAD_STARTROUTINE_T; THREAD_ARG : PTHREAD_ADDR_T; ME : ADA_PTHREAD_T; STATUS : PTHREAD_ADDR_T; CMA_THREAD_PTR : CMA_THREAD_TYPE; JOIN_CNT : INTEGER; DETACHED : BOOLEAN; 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_ENTER_THREAD_ROUTINE( START_ROUTINE : in CMA_TYPES.PTHREAD_STARTROUTINE_T; ARG : in CMA_TYPES.PTHREAD_ADDR_T ) return PTHREAD_ADDR_T; pragma INTERFACE( C, ADA_THD_ENTER_THREAD_ROUTINE ); procedure ADA_THD_RUN_KEY_DESTRUCTORS( KEY : in SYSTEM.ADDRESS ); pragma INTERFACE( C, ADA_THD_RUN_KEY_DESTRUCTORS ); begin loop select accept START( HANDLE : in CMA_TYPES.ADA_PTHREAD_T; START_FUNC : in CMA_TYPES.PTHREAD_STARTROUTINE_T; ARG : in CMA_TYPES.PTHREAD_ADDR_T ) do ME := HANDLE; ENTRY_POINT := START_FUNC; THREAD_ARG := ARG; HANDLE.TCB_PTR := ADA_THD_GET_TASK_TCB_PTR; ADA_THD_ADD_TASK_TO_LIST( HANDLE, HANDLE.TCB_PTR ); end START; STATUS := ADA_THD_ENTER_THREAD_ROUTINE( ENTRY_POINT, THREAD_ARG ); ADA_THD_RUN_KEY_DESTRUCTORS( ME.KEY_LIST'ADDRESS ); ME.INT_LOCK.LOCK; JOIN_CNT := ME.JOIN_CNT; DETACHED := ME.DETACHED; ME.STATE := CMA_TYPES.EXITED; ME.EXIT_STATUS := STATUS; if DETACHED and JOIN_CNT = 0 then FREE_PTHREAD_HANDLE( ME ); elsif JOIN_CNT /= 0 then if ME.JOIN_CV = CMA_TYPES.NULL_INT_CV then ADA_THD_RAISE_EXCEPTION( ADA_USE_ERROR_E ); end if; ME.JOIN_CV.WAKE_ALL; end if; ME.INT_LOCK.UNLOCK; or terminate; end select; end loop; end CMA_THREAD_TASK_TYPE; ------------------------------------------------------------------------ -- -- Task used to implement the internal condition variable -- ------------------------------------------------------------------------ task body INTERNAL_CV_TYPE is begin loop select accept WAKE_ALL; loop select accept WAIT; else exit; end select; end loop; or accept TIMED_WAIT( WAIT_T : in DURATION ) do select accept WAKE_ALL; or delay WAIT_T; end select; end TIMED_WAIT; or terminate; end select; end loop; end INTERNAL_CV_TYPE; ------------------------------------------------------------------------ -- -- This task body is an internal lock used by the pthread mutex code. -- It is used to serialize access into a particular mutexes' data -- structure. -- ------------------------------------------------------------------------ task body INTERNAL_LOCK_TYPE is begin loop select accept LOCK; accept UNLOCK; or accept STOP; or terminate; end select; end loop; end INTERNAL_LOCK_TYPE; function GET_ADA_PTHREAD_ATTR( ATTR : in PTHREAD_ATTR_T ) return ADA_PTHREAD_ATTR_T is use CMA_TYPES; begin if ATTR.FIELD1 = NULL_CMA_T_ADDRESS then ADA_THD_RAISE_EXCEPTION( ADA_INVALID_OBJ_E ); end if; return ( CMA_T_ADDRESS_TO_ADA_PTHREAD_ATTR_T( ATTR.FIELD1) ); end GET_ADA_PTHREAD_ATTR; function GET_ADA_MUTEXATTR( ATTR : in PTHREAD_MUTEXATTR_T ) return ADA_MUTEXATTR_T is begin if ATTR.FIELD1 = NULL_CMA_T_ADDRESS then ADA_THD_RAISE_EXCEPTION( ADA_INVALID_OBJ_E ); end if; return ( CMA_T_ADDRESS_TO_ADA_MUTEXATTR_T( ATTR.FIELD1) ); end GET_ADA_MUTEXATTR; function GET_ADA_COND_ATTR( ATTR : in PTHREAD_CONDATTR_T ) return ADA_CONDATTR_T is begin if ATTR.FIELD1 = NULL_CMA_T_ADDRESS then ADA_THD_RAISE_EXCEPTION( ADA_INVALID_OBJ_E ); end if; return ( CMA_T_ADDRESS_TO_ADA_CONDATTR_T( ATTR.FIELD1) ); end GET_ADA_COND_ATTR; ------------------------------------------------------------------------ -- -- Returns "FIELD1" of a "CMA_T_HANDLE" structure as a "PTHREAD_MUTEX_T" -- pointer. -- ------------------------------------------------------------------------ function GET_ADA_MUTEX_HANDLE( PMUTEX : in PTHREAD_MUTEX_T ) return ADA_PTHREAD_MUTEX_T is use CMA_TYPES; begin if PMUTEX.FIELD1 = NULL_CMA_T_ADDRESS then ADA_THD_RAISE_EXCEPTION( ADA_INVALID_OBJ_E ); end if; return ( CMA_T_ADDRESS_TO_ADA_PTHREAD_MUTEX_T( PMUTEX.FIELD1 )); end GET_ADA_MUTEX_HANDLE; ------------------------------------------------------------------------ -- -- Returns "FIELD1" of a "CMA_T_HANDLE" structure as a "PTHREAD_COND_T" -- pointer. -- ------------------------------------------------------------------------ function GET_ADA_COND_HANDLE( PCOND : in PTHREAD_COND_T ) return ADA_PTHREAD_COND_T is begin if PCOND.FIELD1 = NULL_CMA_T_ADDRESS then ADA_THD_RAISE_EXCEPTION( ADA_INVALID_OBJ_E ); end if; return ( CMA_T_ADDRESS_TO_ADA_PTHREAD_COND_T( PCOND.FIELD1 )); end GET_ADA_COND_HANDLE; ------------------------------------------------------------------------ -- -- Converts the "field1" member of "PTHREAD_T" to a pointer to an -- "ADA_PTHREAD_T" record. -- ------------------------------------------------------------------------ function GET_ADA_THREAD_HANDLE( PTHREAD : in PTHREAD_T ) return ADA_PTHREAD_T is begin if PTHREAD.FIELD1 = NULL_CMA_T_ADDRESS then ADA_THD_RAISE_EXCEPTION( ADA_INVALID_OBJ_E ); end if; return ( CMA_T_ADDRESS_TO_ADA_PTHREAD_T( PTHREAD.FIELD1 ) ); end GET_ADA_THREAD_HANDLE; ------------------------------------------------------------------------ -- -- Determines if the current "pthread_t" is valid. This is done by -- checking for a valid ADA_PTHREAD_T. A 1 is returned if the handle -- is valid. Otherwise, 0 is returned. EXISTS indicates whether the -- "pthread_t" was once valid, but no longer exists (i.e., the thread -- has been detached. -- ------------------------------------------------------------------------ function ADA_THD_IS_HANDLE_VALID ( PTHREAD : in PTHREAD_T; EXISTS : in C_INTEGER_P ) return C_INTEGER is HANDLE : ADA_PTHREAD_T; ANSWER : C_INTEGER; function ADA_THD_RETRIEVE_HANDLE( HANDLE : in ADA_PTHREAD_T ) return SYSTEM.ADDRESS; pragma INTERFACE( C, ADA_THD_RETRIEVE_HANDLE ); use SYSTEM; begin HANDLE := GET_ADA_THREAD_HANDLE( PTHREAD ); if HANDLE = NULL_ADA_PTHREAD_T then TEXT_IO.PUT_LINE( "Handle is NULL" ); end if; if ADA_THD_RETRIEVE_HANDLE( HANDLE ) = SYSTEM.NULL_ADDRESS then EXISTS.all := 0; ANSWER := 0; elsif HANDLE.TASK_ID = NULL_THREAD then EXISTS.all := 1; ANSWER := 0; else EXISTS.all := 1; ANSWER := 1; end if; return ANSWER; end ADA_THD_IS_HANDLE_VALID; function ADA_THD_CREATE_INT_CV return INTERNAL_CV is CV : INTERNAL_CV; begin CV := new INTERNAL_CV_TYPE; return CV; exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( ADA_NO_MEMORY_E ); end ADA_THD_CREATE_INT_CV; function ADA_THD_CREATE_INT_LOCK return INTERNAL_LOCK is LOCK : INTERNAL_LOCK; begin LOCK := new INTERNAL_LOCK_TYPE; return LOCK; exception when STORAGE_ERROR => ADA_THD_RAISE_EXCEPTION( ADA_NO_MEMORY_E ); end ADA_THD_CREATE_INT_LOCK; procedure ADA_THD_LOCK_INT_LOCK( LOCK : INTERNAL_LOCK ) is begin LOCK.LOCK; end ADA_THD_LOCK_INT_LOCK; procedure ADA_THD_UNLOCK_INT_LOCK( LOCK : INTERNAL_LOCK ) is begin LOCK.UNLOCK; end ADA_THD_UNLOCK_INT_LOCK; ------------------------------------------------------------------------ -- -- Creates a task control record for the main task. -- ------------------------------------------------------------------------ function CREATE_MAIN_TASK return ADA_PTHREAD_T is HANDLE : ADA_PTHREAD_T; procedure ADA_THD_ADD_TASK_TO_LIST( THREAD_HANDLE : in ADA_PTHREAD_T; TCB_ID : in SYSTEM.ADDRESS ); pragma INTERFACE( C, ADA_THD_ADD_TASK_TO_LIST ); function ADA_THD_CREATE_MAIN_THREAD_TCB( CV : in INTERNAL_CV; MUTEX : in INTERNAL_LOCK; LOCK : in SYSTEM.ADDRESS ) return SYSTEM.ADDRESS; pragma INTERFACE( C, ADA_THD_CREATE_MAIN_THREAD_TCB ); procedure ADA_THD_INIT_ADA_THREADS( EXC : in ADA_PTHREAD_EXC_T ); pragma INTERFACE( C, ADA_THD_INIT_ADA_THREADS ); begin ADA_THD_INIT_ADA_THREADS( ADA_MAX_EXCEPTIONS ); HANDLE := new ADA_PTHREAD_T_HANDLE; HANDLE.TASK_ID := INT_TO_THREAD( -1 ); HANDLE.TCB_PTR := ADA_THD_GET_TASK_TCB_PTR; HANDLE.WAIT_CV := ADA_THD_CREATE_INT_CV; HANDLE.WAIT_MUTEX := ADA_THD_CREATE_INT_LOCK; HANDLE.CMA_THREAD_TCB := ADA_THD_CREATE_MAIN_THREAD_TCB( HANDLE.WAIT_CV, HANDLE.WAIT_MUTEX, HANDLE.INT_LOCK'ADDRESS ); ADA_THD_ADD_TASK_TO_LIST( HANDLE, HANDLE.TCB_PTR ); return HANDLE; end CREATE_MAIN_TASK; procedure ADA_THD_INT_WAIT( CV : in INTERNAL_CV; MUTEX : in INTERNAL_LOCK ) is begin -- TEXT_IO.PUT_LINE( "WAITING ON INTERNAL CV" ); MUTEX.UNLOCK; CV.WAIT; MUTEX.LOCK; -- TEXT_IO.PUT_LINE( "RETURNING FROM WAIT" ); end ADA_THD_INT_WAIT; procedure ADA_THD_INT_SIGNAL ( CV : in INTERNAL_CV ) is begin -- TEXT_IO.PUT_LINE( "SIGNALLING INTERNAL CV" ); if CV'CALLABLE then CV.WAKE_ALL; end if; end ADA_THD_INT_SIGNAL; procedure ADA_THD_INT_TIMEDWAIT( CV : in INTERNAL_CV; MUTEX : in INTERNAL_LOCK; ABSTIME : in TIME_SPEC_P ) is TDELAY : TIME_SPEC; WAIT_T : DURATION; T_FLAG : C_INTEGER; function ADA_THD_EXPIRATION_TO_DELAY( TS : in CMA_TYPES.TIME_SPEC_P; TD : in SYSTEM.ADDRESS ) return C_INTEGER; pragma INTERFACE( C, ADA_THD_EXPIRATION_TO_DELAY ); function ADA_THD_LONG_TO_FLOAT( VAL : LONG ) return FLOAT; pragma INTERFACE( C, ADA_THD_LONG_TO_FLOAT ); use CALENDAR; begin T_FLAG := ADA_THD_EXPIRATION_TO_DELAY( ABSTIME, TDELAY'ADDRESS ); WAIT_T := DURATION( ADA_THD_LONG_TO_FLOAT( TDELAY.TV_SEC ) ) + DURATION( ADA_THD_LONG_TO_FLOAT( TDELAY.TV_NSEC )/1.0e+9 ); MUTEX.UNLOCK; if T_FLAG = 0 then select CV.TIMED_WAIT( WAIT_T ); else delay WAIT_T; end select; end if; MUTEX.LOCK; end ADA_THD_INT_TIMEDWAIT; procedure ADA_THD_SUSPEND_ADA_TASKING is begin SYSTEM_ENVIRONMENT.SUSPEND_ADA_TASKING; end ADA_THD_SUSPEND_ADA_TASKING; procedure ADA_THD_RESUME_ADA_TASKING is begin SYSTEM_ENVIRONMENT.RESUME_ADA_TASKING; end ADA_THD_RESUME_ADA_TASKING; end CMA_TYPES;