adding atomically to disable yielding in controlled situations

eval.c

@@ -423,6 +423,7 @@ void sexp_init_eval_context_globals (sexp ctx) {
   sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
   sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO;
   sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE;
+  sexp_global(ctx, SEXP_G_ATOMIC_P) = SEXP_FALSE;
 #endif
   sexp_gc_release1(ctx);
 }

include/chibi/sexp.h

@@ -1195,6 +1195,7 @@ enum sexp_context_globals {
   SEXP_G_THREADS_BLOCKER,
   SEXP_G_THREADS_MUTEX_ID,
   SEXP_G_THREADS_POLLFDS_ID,
+  SEXP_G_ATOMIC_P,
 #endif
   SEXP_G_NUM_GLOBALS
 };

lib/chibi/ast.c

@@ -1,5 +1,5 @@
 /*  ast.c -- interface to the Abstract Syntax Tree            */
-/*  Copyright (c) 2009-2011 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2012 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include <chibi/eval.h>
@@ -334,6 +334,12 @@ static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
   return sexp_make_unsigned_integer(ctx, sum_freed);
 }
 
+static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new) {
+  sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P);
+  sexp_global(ctx, SEXP_G_ATOMIC_P) = new;
+  return res;
+}
+
 static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
   const char *res;
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
@@ -476,6 +482,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
   sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
+  sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic);
   sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
   sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
   sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);

lib/chibi/ast.scm

@@ -1,5 +1,5 @@
 ;; ast.scm -- ast utilities
-;; Copyright (c) 2010-2011 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2010-2012 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;;> Abstract Syntax Tree.  Interface to the types used by
@@ -355,3 +355,18 @@
 
 ;;> Returns the first string cursor of @var{pat} in @var{str},
 ;;> of @scheme{#f} if it's not found.
+
+;;> @subsubsubsection{@scheme{(atomically @var{expr})}}
+
+;;> Run @var{expr} atomically, disabling yields.  Ideally should only
+;;> be used for brief, deterministic expressions.  If used incorrectly
+;;> (e.g. running an infinite loop) can render the system unusable.
+;;> Never expose to a sandbox.
+
+(define-syntax atomically
+  (syntax-rules ()
+    ((atomic . body)
+     (let* ((atomic? (%set-atomic! #t))
+            (res (begin . body)))
+       (%set-atomic! atomic?)
+       res))))

lib/chibi/ast.sld

@@ -32,7 +32,7 @@
    port-line port-line-set!
    environment-parent
    type-name type-cpl type-parent type-slots type-num-slots type-printer
-   object-size integer->immediate gc
+   object-size integer->immediate gc atomically
    string-contains integer->error-string
    flatten-dot update-free-vars!)
   (import (scheme))

vm.c

@@ -872,7 +872,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
 #if SEXP_USE_GREEN_THREADS
   if (--fuel <= 0) {
     tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER);
-    if (sexp_applicablep(tmp1)) {
+    if (sexp_applicablep(tmp1) && sexp_not(sexp_global(ctx, SEXP_G_ATOMIC_P))) {
       /* save thread */
       sexp_context_top(ctx) = top;
       sexp_context_ip(ctx) = ip;