mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-11 06:57:33 +02:00
adding atomically to disable yielding in controlled situations
This commit is contained in:
parent
92801f22ce
commit
99211de2b0
6 changed files with 28 additions and 4 deletions
1
eval.c
1
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);
|
||||
}
|
||||
|
|
|
@ -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
|
||||
};
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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))))
|
||||
|
|
|
@ -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))
|
||||
|
|
2
vm.c
2
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;
|
||||
|
|
Loading…
Add table
Reference in a new issue