suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add call-in-continuation

Browse Source 
The `call-in-continuation` function generalizes applying a
continuation to values by accepting a thunk that is called in the
restored continuation. In other words, insteda of having to use the
pattern

 ((call/cc (lambda (k)
             .... (set! saved-k k) ...
             (lambda ()
               original-result))))
 ...
 (saved-k (lambda () new-result))

The extra call and thunk on the capture side can be omitted:

 (call/cc (lambda (k)
            .... (set! saved-k k) ...
            original-result))
 ...
 (call-in-continuation saved-k (lambda () new-result))

At the Chez Scheme level, a `call-in-continuation` in tail position
within a function can avoid forming a closure for its second argument.
The `call-in-continuation` function at the Racket CS level doesn't yet
provide that benefit.

The `call-in-continuation` operation is called `continuation-slice` in
Feeley's "A Better API for First-Class Continuations".
This commit is contained in:
Matthew Flatt 2020-03-13 09:34:12 -06:00
parent 9ef2124a38
commit edfdcb0b6d
13 changed files with 403 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "7.6.0.16") (define version "7.6.0.17")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

40
pkgs/racket-doc/scribblings/reference/cont.scrbl
View File

@ -199,6 +199,46 @@ for @racket[call/cc] to improve performance.}
The @racket[call/ec] binding is an alias for @racket[call-with-escape-continuation]. The @racket[call/ec] binding is an alias for @racket[call-with-escape-continuation].
} }
@defproc[(call-in-continuation [k continuation?]
[proc (-> any)])
any]{
Similar to applying the continuation @racket[k], but instead of
delivering values to the continuation, @racket[proc] is called with
@racket[k] as the continuation of the call (so the result of
@racket[proc] is returned to the continuation). If @racket[k]
is a composable continuation, the continuation of the call to
@racket[proc] is the current continuation extended with @racket[k].
@mz-examples[
(+ 1
(call/cc (lambda (k)
(call-in-continuation k (lambda () 4)))))
(+ 1
(call/cc (lambda (k)
(let ([n 0])
(dynamic-wind
void
(lambda ()
(code:comment @#,elem{@racket[n] accessed after post thunk})
(call-in-continuation k (lambda () n)))
(lambda ()
(set! n 4)))))))
(+ 1
(with-continuation-mark
'n 4
(call/cc (lambda (k)
(with-continuation-mark
'n 0
(call-in-continuation
k
(lambda ()
(code:comment @#,elem{@racket['n] mark accessed in continuation})
(continuation-mark-set-first #f 'n))))))))
]
@history[#:added "7.6.0.17"]}
@defform[(let/cc k body ...+)]{ @defform[(let/cc k body ...+)]{
Equivalent to @racket[(call/cc (lambda (k) body ...))]. Equivalent to @racket[(call/cc (lambda (k) body ...))].
} }

166
pkgs/racket-test-core/tests/racket/prompt-tests.rktl
View File

@ -2424,3 +2424,169 @@
(compose-continuations c1 c1)) (compose-continuations c1 c1))
tag) tag)
'test))) 'test)))
;; ----------------------------------------
(test '(outer)
'call-in-cont
(with-continuation-mark
'k 'outer
(call/cc
(lambda (k)
(values
(with-continuation-mark
'k 'inner
(call-in-continuation
k
(lambda ()
(continuation-mark-set->list
(current-continuation-marks)
'k)))))))))
(test '(outer)
'call-in-cont/ec
(with-continuation-mark
'k 'outer
(call/ec
(lambda (k)
(values
(with-continuation-mark
'k 'inner
(call-in-continuation
k
(lambda ()
(continuation-mark-set->list
(current-continuation-marks)
'k)))))))))
(test '(outer)
'call-in-cont
(with-continuation-mark
'k 'outer
(call/cc
(lambda (k)
(with-continuation-mark
'k 'outer2
(call-in-continuation
k
(lambda ()
(continuation-mark-set->list
(current-continuation-marks)
'k))))))))
(test '(outer)
'call-in-cont
(with-continuation-mark
'k 'outer
(call/cc
(lambda (k)
(with-continuation-mark
'k 'outer2
(values
(with-continuation-mark
'k 'inner
(call-in-continuation
k
(lambda ()
(continuation-mark-set->list
(current-continuation-marks)
'k))))))))))
(test '(outer3)
'call-in-cont
(with-continuation-mark
'k 'outer
(call/cc
(lambda (k)
(call-in-continuation
k
(lambda ()
(with-continuation-mark
'k 'outer3
(continuation-mark-set->list
(current-continuation-marks)
'k))))))))
(test '(post pre)
'call-in-cont/dw
(let ([did '()])
(call/cc
(lambda (k)
(dynamic-wind
(lambda () (set! did (cons 'pre did)))
(lambda ()
(call-in-continuation
k
(lambda () did)))
(lambda () (set! did (cons 'post did))))))))
(test '(pre post2 pre2 post pre)
'call-in-cont/dw
(let ([did '()])
(let ([k (dynamic-wind
(lambda () (set! did (cons 'pre did)))
(lambda ()
(call/cc
(lambda (k)
k)))
(lambda () (set! did (cons 'post did))))])
(if (procedure? k)
(dynamic-wind
(lambda () (set! did (cons 'pre2 did)))
(lambda ()
(call-in-continuation
k
(lambda () did)))
(lambda () (set! did (cons 'post2 did))))
k))))
(test '(y (x orig))
'call-in-cont/comp
(let ([k (call-with-continuation-prompt
(lambda ()
(with-continuation-mark
'here 'orig
(list 'x (call-with-composable-continuation
(lambda (k)
(abort-current-continuation
(default-continuation-prompt-tag)
(lambda () k))))))))])
(with-continuation-mark
'here 'later
(list 'y (call-in-continuation k (lambda ()
(continuation-mark-set-first #f 'here)))))))
(test '(y (x orig))
'call-in-cont/comp
(let ([k (call-with-continuation-prompt
(lambda ()
(with-continuation-mark
'here 'orig
(list 'x (call-with-composable-continuation
(lambda (k)
(abort-current-continuation
(default-continuation-prompt-tag)
(lambda () k))))))))])
(call-with-continuation-prompt
(lambda ()
(with-continuation-mark
'here 'later
(list 'y (call-in-continuation k (lambda ()
(continuation-mark-set-first #f 'here)))))))))
(test '((y (x orig)))
'call-in-cont/comp
(let ([k (call-with-continuation-prompt
(lambda ()
(with-continuation-mark
'here 'orig
(list 'x (call-with-composable-continuation
(lambda (k)
(abort-current-continuation
(default-continuation-prompt-tag)
(lambda () k))))))))])
(with-continuation-mark
'here 'later
(list
(list 'y (call-in-continuation k (lambda ()
(continuation-mark-set-first #f 'here))))))))

1
racket/src/cs/chezpart.sls
View File

@ -27,6 +27,7 @@
date? make-date date? make-date
dynamic-wind dynamic-wind
call-with-current-continuation call-with-current-continuation
call-in-continuation
make-engine engine-block engine-return make-engine engine-block engine-return
current-eval load current-eval load
sleep thread? buffer-mode? sleep thread? buffer-mode?

1
racket/src/cs/primitive/kernel.ss
View File

@ -96,6 +96,7 @@
[cadddr (known-procedure/no-prompt 2)] [cadddr (known-procedure/no-prompt 2)]
[caddr (known-procedure/no-prompt 2)] [caddr (known-procedure/no-prompt 2)]
[cadr (known-procedure/no-prompt 2)] [cadr (known-procedure/no-prompt 2)]
[call-in-continuation (known-procedure 4)]
[call-in-nested-thread (known-procedure 6)] [call-in-nested-thread (known-procedure 6)]
[call-with-composable-continuation (known-procedure 6)] [call-with-composable-continuation (known-procedure 6)]
[call-with-continuation-barrier (known-procedure 2)] [call-with-continuation-barrier (known-procedure 2)]

1
racket/src/cs/rumble.sls
View File

@ -11,6 +11,7 @@
call-with-current-continuation call-with-current-continuation
call-with-composable-continuation call-with-composable-continuation
call-with-escape-continuation call-with-escape-continuation
call-in-continuation
continuation? continuation?
make-continuation-prompt-tag make-continuation-prompt-tag

112
racket/src/cs/rumble/control.ss
View File

@ -51,7 +51,7 @@
;; metacontinuation frames between the abort and prompt are removed ;; metacontinuation frames between the abort and prompt are removed
;; one-by-one, running any winders in each frame. Finally, the ;; one-by-one, running any winders in each frame. Finally, the
;; `resume-k` continuation of the target prompt's metacontinuation is ;; `resume-k` continuation of the target prompt's metacontinuation is
;; called; the `resume-k` is called using `call-in-continuation` to ;; called; the `resume-k` is called using `#%call-in-continuation` to
;; run a thunk in the restored continuation to apply the prompt's ;; run a thunk in the restored continuation to apply the prompt's
;; handler. ;; handler.
;; ;;
@ -199,27 +199,30 @@
(define (maybe-future-barricade tag) (define (maybe-future-barricade tag)
(when (current-future) (when (current-future)
(let ([fp (strip-impersonator (current-future-prompt))] (#%$app/no-inline future-barricade tag)))
[tag (strip-impersonator tag)])
(cond (define (future-barricade tag)
[(eq? fp tag) (let ([fp (strip-impersonator (current-future-prompt))]
;; shortcut: boundary is the future prompt [tag (strip-impersonator tag)])
(void)] (cond
[(eq? tag the-root-continuation-prompt-tag) [(eq? fp tag)
(block-future)] ;; shortcut: boundary is the future prompt
[else (void)]
(let loop ([mc (current-metacontinuation)]) [(eq? tag the-root-continuation-prompt-tag)
(cond (block-future)]
[(null? mc) [else
;; Won't happen normally, since every thread starts with a explicit prompt (let loop ([mc (current-metacontinuation)])
(block-future)] (cond
[(eq? tag (strip-impersonator (metacontinuation-frame-tag (car mc)))) [(null? mc)
(void)] ;; Won't happen normally, since every thread starts with a explicit prompt
[(eq? (metacontinuation-frame-tag (car mc)) fp) (block-future)]
;; tag must be above future prompt [(eq? tag (strip-impersonator (metacontinuation-frame-tag (car mc))))
(block-future)] (void)]
[else [(eq? (metacontinuation-frame-tag (car mc)) fp)
(loop (cdr mc))]))])))) ;; tag must be above future prompt
(block-future)]
[else
(loop (cdr mc))]))])))
(define/who call-with-continuation-prompt (define/who call-with-continuation-prompt
(case-lambda (case-lambda
@ -268,8 +271,8 @@
(assert-not-in-system-wind) (assert-not-in-system-wind)
(call/cc (call/cc
(lambda (resume-k) (lambda (resume-k)
(let ([marks (current-mark-stack)]) ; grab marks before `call-in-continuation` (let ([marks (current-mark-stack)]) ; grab marks before `#%call-in-continuation`
(call-in-continuation (#%call-in-continuation
#%$null-continuation #%$null-continuation
'() '()
(lambda () (lambda ()
@ -302,7 +305,7 @@
[else [else
(start-uninterrupted 'resume-mc) (start-uninterrupted 'resume-mc)
(let ([mf (pop-metacontinuation-frame)]) (let ([mf (pop-metacontinuation-frame)])
(call-in-continuation (#%call-in-continuation
(metacontinuation-frame-resume-k mf) (metacontinuation-frame-resume-k mf)
(metacontinuation-frame-marks mf) (metacontinuation-frame-marks mf)
(lambda () (lambda ()
@ -324,7 +327,7 @@
(call/cc (call/cc
(lambda (resume-k) (lambda (resume-k)
(let ([marks (current-mark-stack)]) (let ([marks (current-mark-stack)])
(call-in-continuation (#%call-in-continuation
#%$null-continuation #%$null-continuation
'() '()
(lambda () (lambda ()
@ -343,7 +346,7 @@
(current-metacontinuation (cons mf (current-metacontinuation))) (current-metacontinuation (cons mf (current-metacontinuation)))
(let ([r (proc (current-metacontinuation))]) (let ([r (proc (current-metacontinuation))])
(let ([mf (pop-metacontinuation-frame)]) (let ([mf (pop-metacontinuation-frame)])
(call-in-continuation (#%call-in-continuation
(metacontinuation-frame-resume-k mf) (metacontinuation-frame-resume-k mf)
(metacontinuation-frame-marks mf) (metacontinuation-frame-marks mf)
(lambda () r))))))))))) (lambda () r)))))))))))
@ -411,6 +414,8 @@
[tag (strip-impersonator tag)]) [tag (strip-impersonator tag)])
(do-abort-current-continuation who tag args #f))) (do-abort-current-continuation who tag args #f)))
;; `args` can be a thunk if `do-abort-current-continuation` is
;; called via `apply-continuation`
(define (do-abort-current-continuation who tag args wind?) (define (do-abort-current-continuation who tag args wind?)
(assert-in-uninterrupted) (assert-in-uninterrupted)
(cond (cond
@ -425,13 +430,15 @@
;; Remove the prompt and resume its continuation ;; Remove the prompt and resume its continuation
;; as we call the handler: ;; as we call the handler:
(let ([mf (pop-metacontinuation-frame)]) (let ([mf (pop-metacontinuation-frame)])
(call-in-continuation (#%call-in-continuation
(metacontinuation-frame-resume-k mf) (metacontinuation-frame-resume-k mf)
(metacontinuation-frame-marks mf) (metacontinuation-frame-marks mf)
(lambda () (lambda ()
(end-uninterrupted/call-hook 'handle) (end-uninterrupted/call-hook 'handle)
(apply (metacontinuation-frame-handler mf) (if (#%procedure? args)
args))))] (args) ; assuming that handler is `values`
(apply (metacontinuation-frame-handler mf)
args)))))]
[else [else
;; Aborting to an enclosing prompt, so keep going: ;; Aborting to an enclosing prompt, so keep going:
(pop-metacontinuation-frame) (pop-metacontinuation-frame)
@ -538,6 +545,17 @@
tag tag
values))) values)))
(define/who (call-in-continuation c proc)
(check who continuation? c)
(cond
[(and (#%procedure? proc)
(chez:procedure-arity-includes? proc 0))
(apply-continuation c proc)]
[else
(check who (procedure-arity-includes/c 0) proc)
(apply-continuation c (lambda () (proc)))]))
;; `args` is either a list or a procedure for which `#%procedure?` is true
(define (apply-continuation c args) (define (apply-continuation c args)
(cond (cond
[(composable-continuation? c) [(composable-continuation? c)
@ -569,7 +587,10 @@
(eq? (car marks) 'empty))))) (eq? (car marks) 'empty)))))
;; Shortcut for no winds and no change to break status: ;; Shortcut for no winds and no change to break status:
(end-uninterrupted 'cc) (end-uninterrupted 'cc)
(#%apply (full-continuation-k c) args)] (if (#%procedure? args)
(#%call-in-continuation (full-continuation-k c) (full-continuation-mark-stack c)
(lambda () (args)))
(#%apply (full-continuation-k c) args))]
[(not (composable-continuation-wind? c)) [(not (composable-continuation-wind? c))
(apply-immediate-continuation/no-wind c args)] (apply-immediate-continuation/no-wind c args)]
[else [else
@ -608,7 +629,10 @@
;; changes or changes to marks (so no break-enabled changes), ;; changes or changes to marks (so no break-enabled changes),
;; and no tag impersonators to deal with ;; and no tag impersonators to deal with
(end-uninterrupted 'cc) (end-uninterrupted 'cc)
(#%apply (full-continuation-k c) args)] (if (#%procedure? args)
(#%call-in-continuation (full-continuation-k c) (full-continuation-mark-stack c)
(lambda () (args)))
(#%apply (full-continuation-k c) args))]
[else [else
(let-values ([(common-mc ; shared part of the current metacontinuation (let-values ([(common-mc ; shared part of the current metacontinuation
rmc-append) ; non-shared part of the destination metacontinuation rmc-append) ; non-shared part of the destination metacontinuation
@ -659,7 +683,7 @@
(activate-and-wrap-cc-guard-for-impersonator! (activate-and-wrap-cc-guard-for-impersonator!
(full-continuation-tag c))) (full-continuation-tag c)))
(end-uninterrupted 'cc) (end-uninterrupted 'cc)
(apply-with-break-transition (full-continuation-k c) args)) (apply-with-break-transition (full-continuation-k c) mark-stack args))
;; If a winder changed the meta-continuation, try again for a ;; If a winder changed the meta-continuation, try again for a
;; non-composable continuation: ;; non-composable continuation:
(and (non-composable-continuation? c) (and (non-composable-continuation? c)
@ -674,7 +698,7 @@
(current-winders (full-continuation-winders c)) (current-winders (full-continuation-winders c))
(current-mark-splice (full-continuation-mark-splice c)) (current-mark-splice (full-continuation-mark-splice c))
(end-uninterrupted 'cc) (end-uninterrupted 'cc)
(apply-with-break-transition (full-continuation-k c) args)) (apply-with-break-transition (full-continuation-k c) (full-continuation-mark-stack c) args))
;; Used as a "handler" for a prompt without a tag, which is used for ;; Used as a "handler" for a prompt without a tag, which is used for
;; composable continuations ;; composable continuations
@ -1885,7 +1909,7 @@
[winders (cdr winders)]) [winders (cdr winders)])
(current-winders winders) (current-winders winders)
(let ([thunk (winder-thunk winder)]) (let ([thunk (winder-thunk winder)])
(call-in-continuation (#%call-in-continuation
(winder-k winder) (winder-k winder)
(winder-marks winder) (winder-marks winder)
(lambda () (lambda ()
@ -1963,15 +1987,15 @@
(define (set-break-enabled-transition-hook! proc) (define (set-break-enabled-transition-hook! proc)
(set! break-enabled-transition-hook proc)) (set! break-enabled-transition-hook proc))
(define (apply-with-break-transition k args) (define (apply-with-break-transition k all-marks args)
;; Install attachments of `k` before calling (#%call-in-continuation
;; `break-enabled-transition-hook`. Technically, the hook is called k
;; with the wrong Scheme continuation, which might keep the all-marks
;; continuation live longer than it should. But the hook can't see (lambda ()
;; the difference, and its only options are to return or escape. (break-enabled-transition-hook)
(current-mark-stack (continuation-next-attachments k)) (if (#%procedure? args)
(break-enabled-transition-hook) (args)
(#%apply k args)) (#%apply values args)))))
;; ---------------------------------------- ;; ----------------------------------------
;; Metacontinuation swapping for engines ;; Metacontinuation swapping for engines

55
racket/src/racket/src/fun.c
View File

@ -83,6 +83,7 @@ static Scheme_Object *ormap (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]); static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *internal_call_cc (int argc, Scheme_Object *argv[]); static Scheme_Object *internal_call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *finish_call_cc (int argc, Scheme_Object *argv[]); static Scheme_Object *finish_call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_in_continuation (int argc, Scheme_Object *argv[]);
static Scheme_Object *propagate_abort (int argc, Scheme_Object *argv[]); static Scheme_Object *propagate_abort (int argc, Scheme_Object *argv[]);
static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[]); static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_continuation_barrier (int argc, Scheme_Object *argv[]); static Scheme_Object *call_with_continuation_barrier (int argc, Scheme_Object *argv[]);
@ -291,6 +292,13 @@ scheme_init_fun (Scheme_Startup_Env *env)
scheme_addto_prim_instance("call-with-current-continuation", o, env); scheme_addto_prim_instance("call-with-current-continuation", o, env);
scheme_addto_prim_instance("call-with-composable-continuation",
scheme_make_prim_w_arity2(call_with_control,
"call-with-composable-continuation",
1, 2,
0, -1),
env);
scheme_addto_prim_instance("continuation?", scheme_addto_prim_instance("continuation?",
scheme_make_folding_prim(continuation_p, scheme_make_folding_prim(continuation_p,
"continuation?", "continuation?",
@ -313,11 +321,11 @@ scheme_init_fun (Scheme_Startup_Env *env)
call_with_prompt_proc, call_with_prompt_proc,
env); env);
scheme_addto_prim_instance("call-with-composable-continuation", scheme_addto_prim_instance("call-in-continuation",
scheme_make_prim_w_arity2(call_with_control, scheme_make_prim_w_arity2(call_in_continuation,
"call-with-composable-continuation", "call-in-continuation",
1, 2, 2, 2,
0, -1), 0, -1),
env); env);
REGISTER_SO(abort_continuation_proc); REGISTER_SO(abort_continuation_proc);
@ -4314,6 +4322,8 @@ do_call_ec (int argc, Scheme_Object *argv[], Scheme_Object *_for_cc)
scheme_check_break_now(); scheme_check_break_now();
if (n != 1) if (n != 1)
v = scheme_values(n, (Scheme_Object **)v); v = scheme_values(n, (Scheme_Object **)v);
else if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_thunk_for_continue_type))
v = _scheme_apply_multi(SCHEME_PTR_VAL(v), 0, NULL);
} else { } else {
scheme_longjmp(*cont->saveerr, 1); scheme_longjmp(*cont->saveerr, 1);
} }
@ -6222,7 +6232,11 @@ internal_call_cc (int argc, Scheme_Object *argv[])
} }
} }
return result; if ((result != SCHEME_MULTIPLE_VALUES)
&& SAME_TYPE(SCHEME_TYPE(result), scheme_thunk_for_continue_type))
return _scheme_tail_apply(SCHEME_PTR_VAL(result), 0, NULL);
else
return result;
} else if (composable || cont->escape_cont) { } else if (composable || cont->escape_cont) {
Scheme_Object *argv2[1]; Scheme_Object *argv2[1];
@ -6249,6 +6263,35 @@ finish_call_cc (int argc, Scheme_Object *argv[])
return do_call_ec(1, argv, argv[1]); return do_call_ec(1, argv, argv[1]);
} }
static Scheme_Object *call_in_continuation (int argc, Scheme_Object *argv[])
{
Scheme_Object *k = argv[0], *p, *a[1];
if (!SCHEME_CONTP(k) && !SCHEME_ECONTP(k))
scheme_wrong_contract("call-in-continuation", "continuation?", 0, argc, argv);
scheme_check_proc_arity("call-in-continuation", 0, 1, argc, argv);
/* Instead of allocating, we chould thread a flag through to say
that the value in `argv` should be applied instead of returned.
But we're not likely to notice the cost of this allocation,
anyway. */
p = scheme_alloc_small_object();
p->type = scheme_thunk_for_continue_type;
SCHEME_PTR_VAL(p) = argv[1];
a[0] = p;
if (SCHEME_CONTP(k)) {
/* We can use escape mode only if coontinuation marks didn't change. */
int can_escape = 0;
return scheme_jump_to_continuation(k, 1, a, MZ_RUNSTACK, can_escape);
} else {
scheme_escape_to_continuation(k, 1, a, NULL);
return NULL;
}
}
static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[]) static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[])
{ {
return ((SCHEME_CONTP(argv[0]) || SCHEME_ECONTP(argv[0])) return ((SCHEME_CONTP(argv[0]) || SCHEME_ECONTP(argv[0]))

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1465 #define EXPECTED_PRIM_COUNT 1466
#ifdef MZSCHEME_SOMETHING_OMITTED #ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP # undef USE_COMPILED_STARTUP

1
racket/src/racket/src/schpriv.h
View File

@ -2026,6 +2026,7 @@ void scheme_about_to_move_C_stack(void);
Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
Scheme_Object **old_runstack, int can_ec); Scheme_Object **old_runstack, int can_ec);
void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full);
Scheme_Object *scheme_chaperone_do_continuation_mark(const char *name, int is_get, Scheme_Object *key, Scheme_Object *val); Scheme_Object *scheme_chaperone_do_continuation_mark(const char *name, int is_get, Scheme_Object *key, Scheme_Object *val);

2
racket/src/racket/src/schvers.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 6 #define MZSCHEME_VERSION_Y 6
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 16 #define MZSCHEME_VERSION_W 17
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x

135
racket/src/racket/src/stypes.h
View File

@ -220,80 +220,81 @@ enum {
scheme_deferred_expr_type, /* 183 */ scheme_deferred_expr_type, /* 183 */
scheme_unquoted_printing_string_type, /* 184 */ scheme_unquoted_printing_string_type, /* 184 */
scheme_will_be_lambda_type, /* 185 */ scheme_will_be_lambda_type, /* 185 */
scheme_thunk_for_continue_type, /* 186 */
#ifdef MZTAG_REQUIRED #ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 186 */ _scheme_last_normal_type_, /* 187 */
/* The remaining tags exist for GC tracing (in non-conservative /* The remaining tags exist for GC tracing (in non-conservative
mode), but they are not needed for run-time tag tests */ mode), but they are not needed for run-time tag tests */
scheme_rt_weak_array, /* 187 */ scheme_rt_weak_array, /* 188 */
scheme_rt_comp_env, /* 188 */ scheme_rt_comp_env, /* 189 */
scheme_rt_constant_binding, /* 189 */ scheme_rt_constant_binding, /* 190 */
scheme_rt_resolve_info, /* 190 */ scheme_rt_resolve_info, /* 191 */
scheme_rt_unresolve_info, /* 191 */ scheme_rt_unresolve_info, /* 192 */
scheme_rt_optimize_info, /* 192 */ scheme_rt_optimize_info, /* 193 */
scheme_rt_cont_mark, /* 193 */ scheme_rt_cont_mark, /* 194 */
scheme_rt_saved_stack, /* 194 */ scheme_rt_saved_stack, /* 195 */
scheme_rt_reply_item, /* 195 */ scheme_rt_reply_item, /* 196 */
scheme_rt_ir_lambda_info, /* 196 */ scheme_rt_ir_lambda_info, /* 197 */
scheme_rt_overflow, /* 197 */ scheme_rt_overflow, /* 198 */
scheme_rt_overflow_jmp, /* 198 */ scheme_rt_overflow_jmp, /* 199 */
scheme_rt_meta_cont, /* 199 */ scheme_rt_meta_cont, /* 200 */
scheme_rt_dyn_wind_cell, /* 200 */ scheme_rt_dyn_wind_cell, /* 201 */
scheme_rt_dyn_wind_info, /* 201 */ scheme_rt_dyn_wind_info, /* 202 */
scheme_rt_dyn_wind, /* 202 */ scheme_rt_dyn_wind, /* 203 */
scheme_rt_dup_check, /* 203 */ scheme_rt_dup_check, /* 204 */
scheme_rt_thread_memory, /* 204 */ scheme_rt_thread_memory, /* 205 */
scheme_rt_input_file, /* 205 */ scheme_rt_input_file, /* 206 */
scheme_rt_input_fd, /* 206 */ scheme_rt_input_fd, /* 207 */
scheme_rt_oskit_console_input, /* 207 */ scheme_rt_oskit_console_input, /* 208 */
scheme_rt_tested_input_file, /* 208 */ scheme_rt_tested_input_file, /* 209 */
scheme_rt_tested_output_file, /* 209 */ scheme_rt_tested_output_file, /* 210 */
scheme_rt_indexed_string, /* 210 */ scheme_rt_indexed_string, /* 211 */
scheme_rt_output_file, /* 211 */ scheme_rt_output_file, /* 212 */
scheme_rt_pipe, /* 212 */ scheme_rt_pipe, /* 213 */
scheme_rt_system_child, /* 213 */ scheme_rt_system_child, /* 214 */
scheme_rt_tcp, /* 214 */ scheme_rt_tcp, /* 215 */
scheme_rt_write_data, /* 215 */ scheme_rt_write_data, /* 216 */
scheme_rt_tcp_select_info, /* 216 */ scheme_rt_tcp_select_info, /* 217 */
scheme_rt_param_data, /* 217 */ scheme_rt_param_data, /* 218 */
scheme_rt_will, /* 218 */ scheme_rt_will, /* 219 */
scheme_rt_finalization, /* 219 */ scheme_rt_finalization, /* 220 */
scheme_rt_finalizations, /* 220 */ scheme_rt_finalizations, /* 221 */
scheme_rt_cpp_object, /* 221 */ scheme_rt_cpp_object, /* 222 */
scheme_rt_cpp_array_object, /* 222 */ scheme_rt_cpp_array_object, /* 223 */
scheme_rt_stack_object, /* 223 */ scheme_rt_stack_object, /* 224 */
scheme_thread_hop_type, /* 224 */ scheme_thread_hop_type, /* 225 */
scheme_rt_srcloc, /* 225 */ scheme_rt_srcloc, /* 226 */
scheme_rt_evt, /* 226 */ scheme_rt_evt, /* 227 */
scheme_rt_syncing, /* 227 */ scheme_rt_syncing, /* 228 */
scheme_rt_comp_prefix, /* 228 */ scheme_rt_comp_prefix, /* 229 */
scheme_rt_user_input, /* 229 */ scheme_rt_user_input, /* 230 */
scheme_rt_user_output, /* 230 */ scheme_rt_user_output, /* 231 */
scheme_rt_compact_port, /* 231 */ scheme_rt_compact_port, /* 232 */
scheme_rt_read_special_dw, /* 232 */ scheme_rt_read_special_dw, /* 233 */
scheme_rt_regwork, /* 233 */ scheme_rt_regwork, /* 234 */
scheme_rt_rx_lazy_string, /* 234 */ scheme_rt_rx_lazy_string, /* 235 */
scheme_rt_buf_holder, /* 235 */ scheme_rt_buf_holder, /* 236 */
scheme_rt_parameterization, /* 236 */ scheme_rt_parameterization, /* 237 */
scheme_rt_print_params, /* 237 */ scheme_rt_print_params, /* 238 */
scheme_rt_read_params, /* 238 */ scheme_rt_read_params, /* 239 */
scheme_rt_native_code, /* 239 */ scheme_rt_native_code, /* 240 */
scheme_rt_native_code_plus_case, /* 240 */ scheme_rt_native_code_plus_case, /* 241 */
scheme_rt_jitter_data, /* 241 */ scheme_rt_jitter_data, /* 242 */
scheme_rt_module_exports, /* 242 */ scheme_rt_module_exports, /* 243 */
scheme_rt_delay_load_info, /* 243 */ scheme_rt_delay_load_info, /* 244 */
scheme_rt_marshal_info, /* 244 */ scheme_rt_marshal_info, /* 245 */
scheme_rt_unmarshal_info, /* 245 */ scheme_rt_unmarshal_info, /* 246 */
scheme_rt_runstack, /* 246 */ scheme_rt_runstack, /* 247 */
scheme_rt_sfs_info, /* 247 */ scheme_rt_sfs_info, /* 248 */
scheme_rt_validate_clearing, /* 248 */ scheme_rt_validate_clearing, /* 249 */
scheme_rt_lightweight_cont, /* 249 */ scheme_rt_lightweight_cont, /* 250 */
scheme_rt_export_info, /* 250 */ scheme_rt_export_info, /* 251 */
scheme_rt_cont_jmp, /* 251 */ scheme_rt_cont_jmp, /* 252 */
scheme_rt_letrec_check_frame, /* 252 */ scheme_rt_letrec_check_frame, /* 253 */
#endif #endif
_scheme_last_type_ _scheme_last_type_

4
racket/src/racket/src/type.c
View File

@ -270,6 +270,8 @@ scheme_init_type ()
set_name(scheme_unquoted_printing_string_type, "<unquoted-printing-string>"); set_name(scheme_unquoted_printing_string_type, "<unquoted-printing-string>");
set_name(scheme_thunk_for_continue_type, "<thunk-for-continue>");
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
set_name(scheme_rt_runstack, "<runstack>"); set_name(scheme_rt_runstack, "<runstack>");
set_name(scheme_rt_meta_cont, "<meta-continuation>"); set_name(scheme_rt_meta_cont, "<meta-continuation>");
@ -649,6 +651,8 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_thread_cell_values_type, small_object); GC_REG_TRAV(scheme_thread_cell_values_type, small_object);
GC_REG_TRAV(scheme_thunk_for_continue_type, small_object);
GC_REG_TRAV(scheme_global_ref_type, twoptr_obj); GC_REG_TRAV(scheme_global_ref_type, twoptr_obj);
GC_REG_TRAV(scheme_delay_syntax_type, small_object); GC_REG_TRAV(scheme_delay_syntax_type, small_object);