Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-10 22:47:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding atomically to disable yielding in controlled situations

Browse source
This commit is contained in:
Alex Shinn 2012-05-06 23:56:06 +09:00
parent 92801f22ce
commit 99211de2b0
6 changed files with 28 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
eval.c
View file

@ -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);
}

1
include/chibi/sexp.h
View file

@ -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
};

9
lib/chibi/ast.c
View file

@ -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);

17
lib/chibi/ast.scm
View file

@ -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))))

2
lib/chibi/ast.sld
View file

@ -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
View file

@ -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;