Here's an initial (unfinished) sketch of an implementation of what I
described yesterday. I haven't tested it, so I don't know whether it
works at all, but it has two major problems first anyway:
1. The semantics of throws out of callbacks should presumably be to
longjmp (and unwind the dstack so that C has a chance to clean up
after itself), but there is nothing to do that right now.
(We could refuse to throw out of callbacks, but then what? We signal
an error and the poor luser will try to abort to the REPL, to no
avail.)
2. The C procedure scheme_callback expects that when the interpreter
returns, via RC_END_OF_COMPUTATION, it will be MICROCODE-CALLBACK that
is returning, but anything else could return via RC_END_OF_COMPUTATION
too.
For (1), using DYNAMIC-WIND in MICROCODE-CALLBACK to intercept throws
out of the callback isn't quite enough -- the consing it does might
trigger a GC interrupt which might trigger an abort to the REPL before
we have set up the DYNAMIC-WIND state to intercept throws.
Maybe the right thing would be to (a) add a new return code meaning
`return from microcode callback' and (b) teach unpack_control_point or
its callers to longjmp if the bottommost return code is that one.
This scheme would need some way of knowing how many longjmps are
necessary, though, and it's not immediately obvious how to do that.
For (2), all I can think of is either to hope it doesn't screw us up,
or to convert everything that currently uses RC_END_OF_COMPUTATION to
use scheme_callback instead.
SCHEME_OBJECT
scheme_callback (SCHEME_OBJECT token, SCHEME_OBJECT argument)
{
/* Grab the Scheme helper. */
SCHEME_OBJECT microcode_callback =
(VECTOR_REF (fixed_objects, MICROCODE_CALLBACK));
/* Save the machine state. */
/* XXX Anything else? Is the LRC necessary? */
SCHEME_OBJECT *return_code = last_return_code;
SCHEME_OBJECT lexpr_actuals = GET_LEXPR_ACTUALS;
SCHEME_OBJECT primitive = GET_PRIMITIVE;
long int_mask = GET_INT_MASK;
SCHEME_OBJECT result;
/* Sanity-check the state of the world. */
/* XXX check, don't assert */
assert (interpreter_applicable_p (microcode_callback));
assert (LONG_TO_FIXNUM_P (int_mask));
/* Set up (MICROCODE-CALLBACK <interrupt-enables> <token> <argument>)
returning to RC_END_OF_COMPUTATION, which returns control to the
microcode. */
SET_RC (RC_END_OF_COMPUTATION);
SET_EXP (SHARP_F);
SAVE_CONT ();
STACK_PUSH (argument);
STACK_PUSH (token);
STACK_PUSH (LONG_TO_FIXNUM (int_mask));
STACK_PUSH (microcode_callback);
PUSH_APPLY_FRAME_HEADER (3);
SET_RC (RC_INTERNAL_APPLY);
SET_EXP (SHARP_F);
SAVE_CONT ();
/* Scheme needs interrupts disabled on entry to CALLBACK-ENTER so
that it can maintain the runtime's callback stack state before
anyone else can muck it up. */
SET_INTERRUPT_MASK (0);
/* Go! */
result = (Re_Enter_Interpreter ());
/* Restore the machine state. */
SET_INTERRUPT_MASK (int_mask);
SET_PRIMITIVE (primitive);
SET_LEXPR_ACTUALS (lexpr_actuals);
last_return_code = return_code;
return (result);
}
(define callbacks (make-rb-tree fix:= fix:<))
(define callback-height 0)
(define callback-waiters (make-rb-tree fix:= fix:<))
(define (allocate-callback-token procedure)
(guarantee-procedure-of-arity procedure 1 'ALLOCATE-CALLBACK-TOKEN)
(without-interrupts
(lambda ()
(do ((token 0 (fix:+ token 1)))
((not (rb-tree/lookup callbacks token))
(rb-tree/insert! callbacks token procedure)
token)
(assert (fix:< token (largest-fixnum)))))))
(define (release-callback-token token)
(guarantee-index-fixnum token 'RELEASE-CALLBACK-TOKEN)
(without-interrupts
(lambda ()
(assert (rb-tree/lookup callbacks token))
(rb-tree/delete! callbacks token))))
(define (call-with-callback-token procedure receiver)
(let ((token))
(dynamic-wind
(let ((entered? #f))
(lambda ()
(if entered? (error "Can't re-enter CALL-WITH-CALLBACK-TOKEN."))
(set! entered? #t)
(set! token (allocate-callback procedure))
unspecific)
(lambda ()
(receiver token))
(lambda ()
(release-callback token))))))
(define (microcode-callback interrupt-enables token argument)
;; Bump the height. Interrupts are blocked so we can safely adjust
;; the runtime's callback height. Since *all* interrupts are
;; blocked, we cannot allocate, so use fixnum-only arithmetic in
;; these assertions. (XXX What about just turning on GC interrupts
;; straight away?)
(let ((height
(let ((h callback-height))
(assert (fix:< h (largest-fixnum)))
(set! callback-height (fix:+ h 1))
h)))
(assert (fixnum? height))
(assert (fix:< 0 height))
(assert (fix:= callback-height (fix:- height 1)))
;; Look up the callback, enable interrupts, and apply it.
(begin0 (let ((procedure (rb-tree/lookup callbacks token)))
(set-interrupt-enables! interrupt-enables)
(procedure argument))
;; Done. Wait until we're the highest callback. Interrupts must
;; be off so nobody can change this until we've returned to the
;; microcode.
(set-interrupt-enables! interrupt-mask/gc-ok)
(if (not (fix:= callback-height height))
(let ((waiters callback-waiters))
(assert (not (rb-tree/lookup waiters height)))
(rb-tree/insert! waiters height (current-thread))
(do () ((fix:= callback-height height))
;; Make sure we're still listed as waiting.
(assert (eq? (current-thread) (rb-tree/lookup waiters height)))
;; Suspension turns interrupts back on. Once someone
;; wakes us, we must turn them back off again before
;; testing the height.
(suspend-current-thread)
(set-interrupt-enables! interrupt-mask/gc-ok))
;; All set. Remove us from the waiters list.
(assert (eq? (current-thread) (rb-tree/lookup waiters height)))
(rb-tree/delete! waiters height)))
;; We are now the highest callback. Signal the callback
;; immediately below us, if there is one. Callbacks further down
;; have to wait for the intermediate one to finish anyway.
(assert (fix:= callback-height height))
(let ((height* (fix:- callback-height 1)))
(cond ((rb-tree/lookup callback-waiters height*)
=> (lambda (thread)
(signal-thread-event thread #t))))
(set! callback-height height*)))))
_______________________________________________
MIT-Scheme-devel mailing list
MIT-Scheme-devel@gnu.org
https://lists.gnu.org/mailman/listinfo/mit-scheme-devel
