revised Mac OS X sleeping; optional atomic mode for FFI callbacks

svn: r13016

collects/mzlib/foreign.ss

@@ -468,17 +468,20 @@
 ;; optionally applying a wrapper function to modify the result primitive
 ;; (callouts) or the input procedure (callbacks).
 (define* (_cprocedure itypes otype
-                      #:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f])
+                      #:abi [abi #f] 
-  (_cprocedure* itypes otype abi wrapper keep))
+                      #:wrapper [wrapper #f] 
+                      #:keep [keep #f]
+                      #:atomic? [atomic? #f])
+  (_cprocedure* itypes otype abi wrapper keep atomic?))
 
 ;; for internal use
 (define held-callbacks (make-weak-hasheq))
-(define (_cprocedure* itypes otype abi wrapper keep)
+(define (_cprocedure* itypes otype abi wrapper keep atomic?)
   (define-syntax-rule (make-it wrap)
     (make-ctype _fpointer
       (lambda (x)
         (and x
-             (let ([cb (ffi-callback (wrap x) itypes otype abi)])
+             (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)])
                (cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
                      [(box? keep)
                       (let ([x (unbox keep)])
@@ -514,6 +517,7 @@
   (define xs     #f)
   (define abi    #f)
   (define keep   #f)
+  (define atomic? #f)
   (define inputs #f)
   (define output #f)
   (define bind   '())
@@ -578,9 +582,10 @@
                      (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
             ...
             [else (err "unknown keyword" (car xs))]))
-        (when (keyword? k) (kwds [#:abi abi] [#:keep keep]))))
+        (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?]))))
     (unless abi  (set! abi  #'#f))
     (unless keep (set! keep #'#t))
+    (unless atomic? (set! atomic? #'#f))
     ;; parse known punctuation
     (set! xs (map (lambda (x)
                     (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_  x]))
@@ -671,9 +676,9 @@
                         (string->symbol (string-append "ffi-wrapper:" n)))
                        body))])
         #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
-                        #,abi (lambda (ffi) #,body) #,keep))
+                        #,abi (lambda (ffi) #,body) #,keep #,atomic?))
       #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
-                      #,abi #f #,keep)))
+                      #,abi #f #,keep #,atomic?)))
   (syntax-case stx ()
     [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
 

collects/scribblings/foreign/types.scrbl

@@ -297,6 +297,7 @@ and normally @scheme[_cprocedure] should be used instead of
 @defproc[(_cprocedure [input-types (list ctype?)]
                       [output-type ctype?]
                       [#:abi abi (or/c symbol/c #f) #f]
+                      [#:atomic? atomic? any/c #f]
                       [#:wrapper wrapper (or/c #f (procedure? . -> . procedure?))
                                          #f]
                       [#:keep keep (or/c boolean? box? (any/c . -> . any/c))
@@ -328,6 +329,16 @@ platform-dependent default; other possible values are
 ``cdecl'').  This is especially important on Windows, where most
 system functions are @scheme['stdcall], which is not the default.
 
+If @scheme[atomic?] is true, then when a Scheme procedure is given
+this procedure type and called from foreign code, then the PLT Scheme
+virtual machine is put into atomic mode while evaluating the Scheme
+procedure body. In atomic mode, other Scheme threads cannot run, so
+the Scheme code must not call any function that potentially
+synchronizes with other threads (including I/O functions). In
+addition, the Scheme code must not raise an uncaught exception, it
+must not perform any escaping continuation jumps, and its non-tail
+recursion must be minimal to avoid C-level stack overflow.
+
 The optional @scheme[wrapper], if provided, is expected to be a
 function that can change a callout procedure: when a callout is
 generated, the wrapper is applied on the newly created primitive
@@ -394,7 +405,8 @@ values: @itemize[
               (_fun fun-option ... maybe-args type-spec ... -> type-spec
                     maybe-wrapper)
               ([fun-option (code:line #:abi  abi-expr)
-                           (code:line #:keep keep-expr)]
+                           (code:line #:keep keep-expr)
+                           (code:line #:atomic? atomic?-expr)]
                [maybe-args code:blank
                            (code:line (id ...) ::)
                            (code:line id ::)

collects/scribblings/foreign/unexported.scrbl

@@ -62,7 +62,8 @@ especially important on Windows, where most system functions are
 
 
 @defproc[(ffi-callback [proc any/c] [in-types any/c] [out-type any/c]
-                       [abi (or/c symbol/c #f) #f])
+                       [abi (or/c symbol/c #f) #f]
+                       [atomic? any/c #f])
          ffi-callback?]{
 
 The symmetric counterpart of @scheme[ffi-call].  It receives a Scheme

src/foreign/foreign.c

@@ -1108,6 +1108,7 @@ typedef struct ffi_callback_struct {
   Scheme_Object* proc;
   Scheme_Object* itypes;
   Scheme_Object* otype;
+  int call_in_scheduler;
 } ffi_callback_struct;
 #define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag)
 #undef MYNAME
@@ -2580,12 +2581,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
     argv = argv_stack;
   else
     argv = scheme_malloc(argc * sizeof(Scheme_Object*));
+  if (data->call_in_scheduler)
+    scheme_start_in_scheduler();
   for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
     v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
     argv[i] = v;
   }
   p = _scheme_apply(data->proc, argc, argv);
   SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
+  if (data->call_in_scheduler)
+    scheme_end_in_scheduler();
 }
 
 /* see ffi-callback below */
@@ -2688,6 +2693,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
   data->proc = (argv[0]);
   data->itypes = (argv[1]);
   data->otype = (argv[2]);
+  data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4])));
 #ifdef MZ_PRECISE_GC
   {
     /* put data in immobile, weak box */
@@ -2853,7 +2859,7 @@ void scheme_init_foreign(Scheme_Env *env)
   scheme_add_global("ffi-call",
     scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
   scheme_add_global("ffi-callback",
-    scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv);
+    scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), menv);
   s = scheme_intern_symbol("void");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;

src/foreign/foreign.ssc

@@ -944,7 +944,8 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
     (callback "void*")
     (proc     "Scheme_Object*")
     (itypes   "Scheme_Object*")
-    (otype    "Scheme_Object*")):}
+    (otype    "Scheme_Object*")
+    (call_in_scheduler "int")):}
 
 /*****************************************************************************/
 /* Pointer objects */
@@ -1969,12 +1970,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
     argv = argv_stack;
   else
     argv = scheme_malloc(argc * sizeof(Scheme_Object*));
+  if (data->call_in_scheduler)
+    scheme_start_in_scheduler();
   for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
     v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
     argv[i] = v;
   }
   p = _scheme_apply(data->proc, argc, argv);
   SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
+  if (data->call_in_scheduler)
+    scheme_end_in_scheduler();
 }
 
 /* see ffi-callback below */
@@ -2005,7 +2010,7 @@ void free_cl_cif_args(void *ignored, void *p)
 /* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */
 /* the treatment of in-types and out-types is similar to that in ffi-call */
 /* the real work is done by ffi_do_callback above */
-{:(cdefine ffi-callback 3 4):}
+{:(cdefine ffi-callback 3 5):}
 {
   ffi_callback_struct *data;
   Scheme_Object *itypes = argv[1];
@@ -2070,7 +2075,8 @@ void free_cl_cif_args(void *ignored, void *p)
   if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
     scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
   {:(cmake-object "data" ffi-callback
-                  "cl_cif_args" "argv[0]" "argv[1]" "argv[2]"):}
+                  "cl_cif_args" "argv[0]" "argv[1]" "argv[2]" 
+                  "((argc > 4) && SCHEME_TRUEP(argv[4]))"):}
 #ifdef MZ_PRECISE_GC
   {
     /* put data in immobile, weak box */

src/mred/mredmac.cxx

@@ -1179,103 +1179,20 @@ int MrEdCheckForBreak(void)
 /***************************************************************************/
 
 #include <pthread.h>
-static volatile int thread_running;
-static volatile int need_post; /* 0=>1 transition has a benign race condition, an optimization */
-static SLEEP_PROC_PTR mzsleep;
-static pthread_t watcher;
-static volatile float sleep_secs;
 
-/* These file descriptors act as semaphores: */
+/* These file descriptors are used for breaking the event loop. */
-static int watch_read_fd, watch_write_fd;
-static int watch_done_read_fd, watch_done_write_fd;
-
-/* These file descriptors are used for breaking the event loop.
-   See ARGH below. */
 static int cb_socket_ready;
 static int ready_sock, write_ready_sock;
 
-#ifdef MZ_PRECISE_GC
-START_XFORM_SKIP;
-#endif
-
-static void *do_watch(void *fds)
-{
-  while (1) {
-    char buf[1];
-
-    read(watch_read_fd, buf, 1);
-
-    mzsleep(sleep_secs, fds);
-    if (need_post) {
-      need_post = 0;
-      if (cb_socket_ready) {
-	/* Sometimes WakeUpProcess() doesn't work. 
-	   Try a notification socket as a backup. 
-	   See ARGH below. */
-	write(write_ready_sock, "y", 1);
-      }
-    }
-
-    write(watch_done_write_fd, "y", 1);
-  }
-
-  return NULL;
-}
-
-#ifdef MZ_PRECISE_GC
-END_XFORM_SKIP;
-#endif
-
 static int StartFDWatcher(void (*mzs)(float secs, void *fds), float secs, void *fds)
 {
-  if (!watch_write_fd) {
+  scheme_start_sleeper_thread(mzs, secs, fds, write_ready_sock);
-    int fds[2];
-    if (!pipe(fds)) {
-      watch_read_fd = fds[0];
-      watch_write_fd = fds[1];
-    } else {
-      return 0;
-    }
-  }
-
-  if (!watch_done_write_fd) {
-    int fds[2];
-    if (!pipe(fds)) {
-      watch_done_read_fd = fds[0];
-      watch_done_write_fd = fds[1];
-    } else {
-      return 0;
-    }
-  }
-
-  if (!watcher) {
-    if (pthread_create(&watcher, NULL,  do_watch, fds)) {
-      return 0;
-    }
-  }
-
-  mzsleep = mzs;
-  sleep_secs = secs;
-  thread_running = 1; 
-  need_post = 1;
-  write(watch_write_fd, "x", 1);
-
   return 1;
 }
 
 static void EndFDWatcher(void)
 {
-  char buf[1];
+  scheme_end_sleeper_thread();
-
-  if (thread_running) {
-    if (need_post) {
-      need_post = 0;
-      scheme_signal_received();
-    }
-
-    read(watch_done_read_fd, buf, 1);
-    thread_running = 0;
-  }
 }
 
 void socket_callback(CFSocketRef s, CFSocketCallBackType type, CFDataRef address, const void *data, void *info)
@@ -1369,11 +1286,8 @@ void MrEdMacSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep)
 
     going++;
 
-    if (need_post) /* useless check in principle, but an optimization
+    if (WNE(&e, secs ? secs : kEventDurationForever))
-		      in the case that the select() succeeds before
+      QueueTransferredEvent(&e);
-		      we even start */
-      if (WNE(&e, secs ? secs : kEventDurationForever))
-	QueueTransferredEvent(&e);
 
     --going;
 

src/mzscheme/include/mzscheme.exp

@@ -23,6 +23,8 @@ scheme_get_current_thread
 scheme_start_atomic
 scheme_end_atomic
 scheme_end_atomic_no_swap
+scheme_start_in_scheduler
+scheme_end_in_scheduler
 scheme_out_of_fuel
 scheme_thread
 scheme_thread_w_details
@@ -43,6 +45,8 @@ scheme_wait_input_allowed
 scheme_unless_ready
 scheme_in_main_thread
 scheme_cancel_sleep
+scheme_start_sleeper_thread
+scheme_end_sleeper_thread
 scheme_make_thread_cell
 scheme_thread_cell_get
 scheme_thread_cell_set

src/mzscheme/include/mzscheme3m.exp

@@ -23,6 +23,8 @@ scheme_get_current_thread
 scheme_start_atomic
 scheme_end_atomic
 scheme_end_atomic_no_swap
+scheme_start_in_scheduler
+scheme_end_in_scheduler
 scheme_out_of_fuel
 scheme_thread
 scheme_thread_w_details
@@ -43,6 +45,8 @@ scheme_wait_input_allowed
 scheme_unless_ready
 scheme_in_main_thread
 scheme_cancel_sleep
+scheme_start_sleeper_thread
+scheme_end_sleeper_thread
 scheme_make_thread_cell
 scheme_thread_cell_get
 scheme_thread_cell_set

src/mzscheme/include/mzwin.def

@@ -25,6 +25,8 @@ EXPORTS
  scheme_start_atomic
  scheme_end_atomic
  scheme_end_atomic_no_swap
+ scheme_start_in_scheduler
+ scheme_end_in_scheduler
  scheme_out_of_fuel
  scheme_thread
  scheme_thread_w_details
@@ -45,6 +47,8 @@ EXPORTS
  scheme_unless_ready
  scheme_in_main_thread
  scheme_cancel_sleep
+ scheme_start_sleeper_thread
+ scheme_end_sleeper_thread
  scheme_make_thread_cell
  scheme_thread_cell_get
  scheme_thread_cell_set

src/mzscheme/include/mzwin3m.def

@@ -25,6 +25,8 @@ EXPORTS
  scheme_start_atomic
  scheme_end_atomic
  scheme_end_atomic_no_swap
+ scheme_start_in_scheduler
+ scheme_end_in_scheduler
  scheme_out_of_fuel
  scheme_thread
  scheme_thread_w_details
@@ -45,6 +47,8 @@ EXPORTS
  scheme_unless_ready
  scheme_in_main_thread
  scheme_cancel_sleep
+ scheme_start_sleeper_thread
+ scheme_end_sleeper_thread
  scheme_make_thread_cell
  scheme_thread_cell_get
  scheme_thread_cell_set

src/mzscheme/src/mzstkchk.h

@@ -9,10 +9,11 @@
   unsigned long _stk_pos;
 
   _stk_pos = (unsigned long)&_stk_pos;
-  if (STK_COMP(_stk_pos, (unsigned long)SCHEME_CURRENT_PROCESS->stack_end))
+  if (STK_COMP(_stk_pos, (unsigned long)SCHEME_CURRENT_PROCESS->stack_end)
+      && !scheme_no_stack_overflow)
 #else
 # ifdef USE_STACKAVAIL
-  if (stackavail() < STACK_SAFETY_MARGIN)
+  if ((stackavail() < STACK_SAFETY_MARGIN) && !scheme_no_stack_overflow)
 # endif
 # if defined(UNIX_FIND_STACK_BOUNDS) || defined(WINDOWS_FIND_STACK_BOUNDS) \
      || defined(MACOS_FIND_STACK_BOUNDS) || defined(ASSUME_FIXED_STACK_SIZE) \
@@ -22,7 +23,8 @@
 
   _stk_pos = (unsigned long)&_stk_pos;
 
-  if (STK_COMP(_stk_pos, SCHEME_STACK_BOUNDARY))
+  if (STK_COMP(_stk_pos, SCHEME_STACK_BOUNDARY)
+      && !scheme_no_stack_overflow)
 # endif
 #endif
 

src/mzscheme/src/port.c

@@ -8291,6 +8291,111 @@ void scheme_start_itimer_thread(long usec)
 
 #endif
 
+
+#ifdef OS_X
+
+/* Sleep-in-thread support needed for GUIs Mac OS X.
+   To merge waiting on a CoreFoundation event with a select(), an embedding
+   application can attach a single socket to an event callback, and then
+   create a Mac thread to call the usual sleep and write to the socket when
+   data is available. */
+
+#ifdef MZ_PRECISE_GC
+START_XFORM_SKIP;
+#endif
+
+typedef struct {
+  pthread_mutex_t lock;
+  pthread_cond_t cond;
+  int count;
+} pt_sema_t;
+
+void pt_sema_init(pt_sema_t *sem)
+{
+  pthread_mutex_init(&sem->lock, NULL);
+  pthread_cond_init(&sem->cond, NULL);
+  sem->count = 0;
+}
+
+void pt_sema_wait(pt_sema_t *sem)
+{
+  pthread_mutex_lock(&sem->lock);
+  while (sem->count <= 0)
+    pthread_cond_wait(&sem->cond, &sem->lock);
+  sem->count--;
+  pthread_mutex_unlock(&sem->lock);
+}
+
+void pt_sema_post(pt_sema_t *sem)
+{
+  pthread_mutex_lock(&sem->lock);
+  sem->count++;
+  if (sem->count > 0)
+    pthread_cond_signal(&sem->cond);
+  pthread_mutex_unlock(&sem->lock);
+}
+
+static pthread_t watcher;
+static pt_sema_t sleeping_sema, done_sema;
+static float sleep_secs;
+static int slept_fd;
+static void *sleep_fds;
+static void (*sleep_sleep)(float seconds, void *fds);
+
+static void *do_watch()
+{
+  while (1) {
+    pt_sema_wait(&sleeping_sema);
+
+    sleep_sleep(sleep_secs, sleep_fds);
+    write(slept_fd, "y", 1);
+
+    pt_sema_post(&done_sema);
+  }
+}
+
+void scheme_start_sleeper_thread(void (*given_sleep)(float seconds, void *fds), float secs, void *fds, int hit_fd)
+{
+  if (!watcher) {
+    pt_sema_init(&sleeping_sema);
+    pt_sema_init(&done_sema);
+
+    if (pthread_create(&watcher, NULL, do_watch, NULL)) {
+      scheme_log_abort("pthread_create failed");
+      abort();
+    }
+  }
+
+  sleep_sleep = given_sleep;
+  sleep_fds = fds;
+  sleep_secs = secs;
+  slept_fd = hit_fd;
+  pt_sema_post(&sleeping_sema);
+}
+
+void scheme_end_sleeper_thread()
+{
+  scheme_signal_received();
+  pt_sema_wait(&done_sema);
+
+  /* Clear external event flag */
+  if (external_event_fd) {
+    char buf[10];
+    read(external_event_fd, buf, 10);
+  }
+}
+
+#ifdef MZ_PRECISE_GC
+END_XFORM_SKIP;
+#endif
+
+#else
+
+void scheme_start_sleeper_thread(void *fds, int hit_fd);
+void scheme_end_sleeper_thread();
+
+#endif
+
 /*========================================================================*/
 /*                       memory debugging help                            */
 /*========================================================================*/

src/mzscheme/src/schemef.h

@@ -82,6 +82,8 @@ MZ_EXTERN Scheme_Thread *scheme_get_current_thread();
 MZ_EXTERN void scheme_start_atomic(void);
 MZ_EXTERN void scheme_end_atomic(void);
 MZ_EXTERN void scheme_end_atomic_no_swap(void);
+MZ_EXTERN void scheme_start_in_scheduler(void);
+MZ_EXTERN void scheme_end_in_scheduler(void);
 
 MZ_EXTERN void scheme_out_of_fuel(void);
 
@@ -120,6 +122,9 @@ MZ_EXTERN int scheme_in_main_thread(void);
 
 MZ_EXTERN void scheme_cancel_sleep(void);
 
+MZ_EXTERN void scheme_start_sleeper_thread(void (*mzsleep)(float seconds, void *fds), float secs, void *fds, int hit_fd);
+MZ_EXTERN void scheme_end_sleeper_thread();
+
 MZ_EXTERN Scheme_Object *scheme_make_thread_cell(Scheme_Object *def_val, int inherited);
 MZ_EXTERN Scheme_Object *scheme_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells);
 MZ_EXTERN void scheme_thread_cell_set(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v);

src/mzscheme/src/schemex.h

@@ -66,6 +66,8 @@ Scheme_Thread *(*scheme_get_current_thread)();
 void (*scheme_start_atomic)(void);
 void (*scheme_end_atomic)(void);
 void (*scheme_end_atomic_no_swap)(void);
+void (*scheme_start_in_scheduler)(void);
+void (*scheme_end_in_scheduler)(void);
 void (*scheme_out_of_fuel)(void);
 Scheme_Object *(*scheme_thread)(Scheme_Object *thunk);
 Scheme_Object *(*scheme_thread_w_details)(Scheme_Object *thunk, 
@@ -95,6 +97,8 @@ void (*scheme_wait_input_allowed)(Scheme_Input_Port *port, int nonblock);
 int (*scheme_unless_ready)(Scheme_Object *unless);
 int (*scheme_in_main_thread)(void);
 void (*scheme_cancel_sleep)(void);
+void (*scheme_start_sleeper_thread)(void (*mzsleep)(float seconds, void *fds), float secs, void *fds, int hit_fd);
+void (*scheme_end_sleeper_thread)();
 Scheme_Object *(*scheme_make_thread_cell)(Scheme_Object *def_val, int inherited);
 Scheme_Object *(*scheme_thread_cell_get)(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells);
 void (*scheme_thread_cell_set)(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v);

src/mzscheme/src/schemex.inc

@@ -31,6 +31,8 @@
   scheme_extension_table->scheme_start_atomic = scheme_start_atomic;
   scheme_extension_table->scheme_end_atomic = scheme_end_atomic;
   scheme_extension_table->scheme_end_atomic_no_swap = scheme_end_atomic_no_swap;
+  scheme_extension_table->scheme_start_in_scheduler = scheme_start_in_scheduler;
+  scheme_extension_table->scheme_end_in_scheduler = scheme_end_in_scheduler;
   scheme_extension_table->scheme_out_of_fuel = scheme_out_of_fuel;
   scheme_extension_table->scheme_thread = scheme_thread;
   scheme_extension_table->scheme_thread_w_details = scheme_thread_w_details;
@@ -51,6 +53,8 @@
   scheme_extension_table->scheme_unless_ready = scheme_unless_ready;
   scheme_extension_table->scheme_in_main_thread = scheme_in_main_thread;
   scheme_extension_table->scheme_cancel_sleep = scheme_cancel_sleep;
+  scheme_extension_table->scheme_start_sleeper_thread = scheme_start_sleeper_thread;
+  scheme_extension_table->scheme_end_sleeper_thread = scheme_end_sleeper_thread;
   scheme_extension_table->scheme_make_thread_cell = scheme_make_thread_cell;
   scheme_extension_table->scheme_thread_cell_get = scheme_thread_cell_get;
   scheme_extension_table->scheme_thread_cell_set = scheme_thread_cell_set;

src/mzscheme/src/schemexm.h

@@ -31,6 +31,8 @@
 #define scheme_start_atomic (scheme_extension_table->scheme_start_atomic)
 #define scheme_end_atomic (scheme_extension_table->scheme_end_atomic)
 #define scheme_end_atomic_no_swap (scheme_extension_table->scheme_end_atomic_no_swap)
+#define scheme_start_in_scheduler (scheme_extension_table->scheme_start_in_scheduler)
+#define scheme_end_in_scheduler (scheme_extension_table->scheme_end_in_scheduler)
 #define scheme_out_of_fuel (scheme_extension_table->scheme_out_of_fuel)
 #define scheme_thread (scheme_extension_table->scheme_thread)
 #define scheme_thread_w_details (scheme_extension_table->scheme_thread_w_details)
@@ -51,6 +53,8 @@
 #define scheme_unless_ready (scheme_extension_table->scheme_unless_ready)
 #define scheme_in_main_thread (scheme_extension_table->scheme_in_main_thread)
 #define scheme_cancel_sleep (scheme_extension_table->scheme_cancel_sleep)
+#define scheme_start_sleeper_thread (scheme_extension_table->scheme_start_sleeper_thread)
+#define scheme_end_sleeper_thread (scheme_extension_table->scheme_end_sleeper_thread)
 #define scheme_make_thread_cell (scheme_extension_table->scheme_make_thread_cell)
 #define scheme_thread_cell_get (scheme_extension_table->scheme_thread_cell_get)
 #define scheme_thread_cell_set (scheme_extension_table->scheme_thread_cell_set)

src/mzscheme/src/schpriv.h

@@ -362,6 +362,8 @@ extern mz_proc_thread *scheme_master_proc_thread;
 extern THREAD_LOCAL mz_proc_thread *proc_thread_self;
 #endif
 
+extern int scheme_no_stack_overflow;
+
 typedef struct Scheme_Thread_Set {
   Scheme_Object so;
   struct Scheme_Thread_Set *parent;

src/mzscheme/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.1.3.8"
+#define MZSCHEME_VERSION "4.1.3.9"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 8
+#define MZSCHEME_VERSION_W 9
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/mzscheme/src/thread.c

@@ -220,6 +220,7 @@ static int missed_context_switch = 0;
 static int have_activity = 0;
 int scheme_active_but_sleeping = 0;
 static int thread_ended_with_activity;
+int scheme_no_stack_overflow;
 
 static int needs_sleep_cancelled;
 
@@ -3437,13 +3438,16 @@ static int check_sleep(int need_activity, int sleep_now)
 {
   Scheme_Thread *p, *p2;
   int end_with_act;
-  
+
 #if defined(USING_FDS)
   DECL_FDSET(set, 3);
   fd_set *set1, *set2;
 #endif
   void *fds;
 
+  if (scheme_no_stack_overflow)
+    return 0;
+  
   /* Is everything blocked? */
   if (!do_atomic) {
     p = scheme_first_thread;
@@ -3641,7 +3645,7 @@ static int can_break_param(Scheme_Thread *p)
 
 int scheme_can_break(Scheme_Thread *p)
 {
-  if (!p->suspend_break) {
+  if (!p->suspend_break && !scheme_no_stack_overflow) {
     return can_break_param(p);
   } else
     return 0;
@@ -4361,6 +4365,18 @@ void scheme_end_atomic_no_swap(void)
   --do_atomic;
 }
 
+void scheme_start_in_scheduler(void)
+{
+  do_atomic++;
+  scheme_no_stack_overflow++;
+}
+      
+void scheme_end_in_scheduler(void)
+{
+  --do_atomic;
+  --scheme_no_stack_overflow;
+}
+
 void scheme_end_atomic(void)
 {
   scheme_end_atomic_no_swap();