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_BACK) = SEXP_NULL;
|
||||||
sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO;
|
sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO;
|
||||||
sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE;
|
sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE;
|
||||||
|
sexp_global(ctx, SEXP_G_ATOMIC_P) = SEXP_FALSE;
|
||||||
#endif
|
#endif
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release1(ctx);
|
||||||
}
|
}
|
||||||
|
|
|
@ -1195,6 +1195,7 @@ enum sexp_context_globals {
|
||||||
SEXP_G_THREADS_BLOCKER,
|
SEXP_G_THREADS_BLOCKER,
|
||||||
SEXP_G_THREADS_MUTEX_ID,
|
SEXP_G_THREADS_MUTEX_ID,
|
||||||
SEXP_G_THREADS_POLLFDS_ID,
|
SEXP_G_THREADS_POLLFDS_ID,
|
||||||
|
SEXP_G_ATOMIC_P,
|
||||||
#endif
|
#endif
|
||||||
SEXP_G_NUM_GLOBALS
|
SEXP_G_NUM_GLOBALS
|
||||||
};
|
};
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
/* ast.c -- interface to the Abstract Syntax Tree */
|
/* 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 */
|
/* BSD-style license: http://synthcode.com/license.txt */
|
||||||
|
|
||||||
#include <chibi/eval.h>
|
#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);
|
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) {
|
static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
|
||||||
const char *res;
|
const char *res;
|
||||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
|
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(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_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, "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(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_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);
|
sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;; ast.scm -- ast utilities
|
;; 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
|
;; BSD-style license: http://synthcode.com/license.txt
|
||||||
|
|
||||||
;;> Abstract Syntax Tree. Interface to the types used by
|
;;> Abstract Syntax Tree. Interface to the types used by
|
||||||
|
@ -355,3 +355,18 @@
|
||||||
|
|
||||||
;;> Returns the first string cursor of @var{pat} in @var{str},
|
;;> Returns the first string cursor of @var{pat} in @var{str},
|
||||||
;;> of @scheme{#f} if it's not found.
|
;;> 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!
|
port-line port-line-set!
|
||||||
environment-parent
|
environment-parent
|
||||||
type-name type-cpl type-parent type-slots type-num-slots type-printer
|
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
|
string-contains integer->error-string
|
||||||
flatten-dot update-free-vars!)
|
flatten-dot update-free-vars!)
|
||||||
(import (scheme))
|
(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 SEXP_USE_GREEN_THREADS
|
||||||
if (--fuel <= 0) {
|
if (--fuel <= 0) {
|
||||||
tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER);
|
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 */
|
/* save thread */
|
||||||
sexp_context_top(ctx) = top;
|
sexp_context_top(ctx) = top;
|
||||||
sexp_context_ip(ctx) = ip;
|
sexp_context_ip(ctx) = ip;
|
||||||
|
|
Loading…
Add table
Reference in a new issue