[plt-scheme] High precision timing and MrEd/OSX.

I use PLT for musical work and have written a high precision timer
extension based on setitimer(2).  The extension works correctly on
Linux and on OSX/mzscheme, but fails on OSX/MrEd.

I imagine this may be a signal problem.  I have checked the PLT
sources for setitimer and SIGALRM but there does not seem to be
anything OSX specific there.  (There is a reference under
wxmac/utils/image/src/wx_imgx.h but this is common to the Xt file.)

Is this a known issue?  Does anyone have any suggestions?  Is there a
timer that is known to work under MrEd/OSX that I should use instead
of setitimer?

The C module file is included below.  The basic design is: the client
registers a semaphore object that is posted to when a timer elapses,
the client installs a thread to wait on the semaphore, the client sets
the timer as required.  (It is part of a larger project that is
available at <http://www.alphalink.com.au/~rd> if anyone needs more
context.)

Regards,
Rohan

/***** high-precision-time-core.c - (c) rohan drape 2003-2004 *****/

/* A High Precision Time module for mzscheme under POSIX systems.
   Exports procedures with a high-precision-time prefix.  get-time
   gets the current time as a real valued UTC time stamp.
   set-semaphore sets the semaphore to post to when a timer expires.
   set-timer sets a timer.  accuracy-log sets the accuracy logging
   status or returns the current set of log values. */

/* This needs to be defined to get the fmax procedure from math.h with
   gcc, otherwise it makes wrong results. */
#define _ISOC99_SOURCE

#include <unistd.h>
#include <stdio.h>
#include <stdbool.h>
#include <signal.h>
#include <math.h>
#include <sys/time.h>
#include "escheme.h"

typedef struct 
{
  /* The semaphore that is posted to when the timer elapses. */
  Scheme_Object *semaphore ;

  /* When a timer request is made both the time the request arrived
     and the time that was requested are stored.  */
  double request_at ;
  double request_for ;
  
  /* Accuracy logging stores the actual time the semaphore was posted
     to and the jitter from the requested time.  The setitimer
     function can return early (up to .03 seconds) on some
     platforms. */
  int accuracy_log ;
  double post_at ;
  double jitter ;
} 
high_precision_time_t ;

/* Single instance of data structure. */
high_precision_time_t h ;

/* Convert between double precision and timeval representations of a
   time point. */

static struct timeval
double_to_timeval ( double d ) 
{
  struct timeval t ;
  t.tv_sec  = (long) floor ( d ) ;
  t.tv_usec = (long) ceil ( ( d - (double)t.tv_sec ) * 1000000.0 ) ;
  return t ;
}

static double
timeval_to_double ( struct timeval t ) 
{
  return (double)t.tv_sec + ( (double)t.tv_usec / 1000000.0 ) ;
}

/* Get the current time as a UTC double precision value. */

static double
current_time_as_utc_double ( void ) 
{
  struct timeval current ;
  gettimeofday ( &current , NULL ) ; 
  return timeval_to_double ( current ) ;
}
  
/* Called from the signal handler, or directly from the :set-timer
   procedure, to make the dispatch. */

static void
set_timer_dispatch ( void )
{
  if ( h.accuracy_log ) {
    h.post_at = current_time_as_utc_double () ;
    h.jitter = h.post_at - h.request_for ;
  }
  scheme_post_sema ( h.semaphore ) ;
}

/* Procedure to set or get the accuracy log. */

static Scheme_Object*
accuracy_log ( int argc , Scheme_Object **argv )
{
  if ( argc == 1 ) {
    h.accuracy_log = SCHEME_TRUEP ( argv[0] ) ;
    return argv[0] ;
  } else {
    Scheme_Object *result[4] ;
    result[0] = scheme_make_double ( h.request_at ) ;
    result[1] = scheme_make_double ( h.request_for ) ;
    result[2] = scheme_make_double ( h.post_at ) ;
    result[3] = scheme_make_double ( h.jitter ) ;
    return scheme_build_list ( 4 , result ) ;
  }
}

/* Procedure to get the current time as a real valued UTC time. */

static Scheme_Object*
get_time ( int argc , Scheme_Object **argv )
{
  return scheme_make_double ( current_time_as_utc_double () ) ;
}

/* Procedure to request that argv[0], a semaphore, be posted to when a
   timer elapses. */

static Scheme_Object*
set_semaphore ( int argc , Scheme_Object **argv )
{
  h.semaphore = argv[0] ;
  return scheme_void ;
}

/* Procedure to request that the previously set semaphore be posted to
   at time argv[0], a double representing a real value UTC time.  Any
   subsequent call overwrites the existing timer. */

static Scheme_Object*
set_timer ( int argc , Scheme_Object **argv )
{
  /* Store requested time and get current time. */
  h.request_for = scheme_real_to_double ( argv[0] ) ;
  h.request_at = current_time_as_utc_double () ;
  
  /* If the request is in the past dispatch and return immediately. */
  if ( h.request_for < h.request_at ) {
    set_timer_dispatch () ;
    return scheme_void ;
  }

  /* Set alarm and return. */
  struct itimerval t ;
  t.it_interval.tv_usec = 0 ;
  t.it_interval.tv_sec = 0 ;
  t.it_value = double_to_timeval ( h.request_for - h.request_at ) ;
  setitimer ( ITIMER_REAL , &t , NULL ) ;
  return scheme_void ;
} 

/* Add a fixed-arity primitive to a module. */

static void
add_procedure ( const char *name , Scheme_Prim *proc , 
		int min_arity , int max_arity , 
		Scheme_Env *env )
{
  scheme_add_global ( name ,
		      scheme_make_prim_w_arity ( proc , 
						 name ,
						 min_arity ,
						 max_arity ) ,
		      env ) ;
}

/* The SIGALRM signal handler. */

static void 
alarm_signal_handler ( int signum ) 
{
  set_timer_dispatch () ;
}

/* The extension initializer. */

Scheme_Object *
scheme_reload ( Scheme_Env *env ) 
{
  Scheme_Object *module_name ;
  Scheme_Env *module_env ;
  module_name = scheme_intern_symbol ( "high-precision-time-core" ) ;
  module_env = scheme_primitive_module ( module_name , env ) ;
  add_procedure ( "high-precision-time:accuracy-log" , 
		  accuracy_log , 0 , 1 , module_env ) ;
  add_procedure ( "high-precision-time:get-time" , 
		  get_time , 0 , 0 , module_env ) ;
  add_procedure ( "high-precision-time:set-timer" , 
		  set_timer , 1 , 1 , module_env ) ;
  add_procedure ( "high-precision-time:set-semaphore" , 
		  set_semaphore , 1 , 1 , module_env ) ;
  scheme_finish_primitive_module ( module_env ) ;
  return scheme_void ;
}

Scheme_Object *
scheme_initialize ( Scheme_Env *env ) 
{
  struct sigaction action ;  
  action.sa_handler = alarm_signal_handler ;
  sigemptyset ( &action.sa_mask ) ;
  action.sa_flags = 0 ;
  sigaction ( SIGALRM , &action , NULL ) ;
  h.request_at = 0.0 ;
  h.request_for = 0.0 ;
  h.semaphore = scheme_void ;
  h.accuracy_log = false ;
  h.post_at = 0.0 ;
  h.jitter = 0.0 ;
  return scheme_reload ( env ) ;
}

Scheme_Object *
scheme_module_name ( void ) 
{
  return scheme_intern_symbol ( "high-precision-time-core" ) ;
}