diff --git a/eval.c b/eval.c index ed4859c3..64a1f85e 100644 --- a/eval.c +++ b/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); } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index b10c5fcf..62097f1e 100755 --- a/include/chibi/sexp.h +++ b/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 }; diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 979c2cde..6497c1db 100644 --- a/lib/chibi/ast.c +++ b/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 @@ -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); diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm index 99f5975f..4fc58791 100644 --- a/lib/chibi/ast.scm +++ b/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)))) diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index 74b90c16..2124e9a8 100644 --- a/lib/chibi/ast.sld +++ b/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)) diff --git a/vm.c b/vm.c index a92dd837..4e8cbd41 100644 --- a/vm.c +++ b/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;