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

add continuation-mark-set->iterator

Browse Source 
Support continuation-mark inspection proportional to the amount that
needs to be inspected, instead of having to build a list of length
propotional to the size of a continuation.

In Racket CS, use iteration to improve exception-handling chaining.
Traditional Racket already used similar functonality internally.
This commit is contained in:
Matthew Flatt 2019-11-10 14:35:10 -06:00
parent 8aef27ccf5
commit 5eb04dfa9e
11 changed files with 332 additions and 130 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 version "7.5.0.6")
(define version "7.5.0.7")
(define deps `("racket-lib"
["racket" #:version ,version]))

40
pkgs/racket-benchmarks/tests/racket/benchmarks/control/exn.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket/base
(require racket/include)
(include "config.rktl")
'----------------------------------------
'exn
(time
(for/fold ([v #f]) ([i (in-range Q)])
(with-handlers ([(lambda (x) #t) (lambda (x) 'caught)])
(raise 'exn))))
'exn-deep
(time
(let loop ([n 1000])
(if (zero? n)
(for/fold ([v #f]) ([i (in-range Q)])
(with-handlers ([(lambda (x) #t) (lambda (x) 'caught)])
(raise 'exn)))
(with-continuation-mark
'key 'val
(values (loop (sub1 n)))))))
;; Runs a chain of 1000 handlers
'exn-chain
(time
(for/fold ([v #f]) ([i (in-range (quotient Q 100))])
(let/ec esc
(call-with-exception-handler
(lambda (exn) (esc 'done))
(lambda ()
(let loop ([n 1000])
(if (zero? n)
(raise 'exn)
(call-with-exception-handler
(lambda (exn) exn)
(lambda ()
(values (loop (sub1 n))))))))))))

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

@ -85,7 +85,9 @@ Returns a newly-created list containing the marks for @racket[key-v]
in @racket[mark-set], which is a set of marks returned by
@racket[current-continuation-marks]. The result list is truncated at
the first point, if any, where continuation frames were originally
separated by a prompt tagged with @racket[prompt-tag].}
separated by a prompt tagged with @racket[prompt-tag]. Producing the result
takes time proportional to the size of the continuation reflected by
@racket[mark-set].}
@defproc*[([(make-continuation-mark-key) continuation-mark-key?]
[(make-continuation-mark-key [sym symbol?]) continuation-mark-key?])]{
@ -114,7 +116,30 @@ particular vector position is the value for the corresponding key in
@racket[key-list]. Values for multiple keys appear in a single vector
only when the marks are for the same continuation frame in
@racket[mark-set]. The @racket[none-v] argument is used for vector
elements to indicate the lack of a value.}
elements to indicate the lack of a value. Producing the result
takes time proportional to the size of the continuation reflected by
@racket[mark-set] times the length of @racket[key-list].}
@defproc[(continuation-mark-set->iterator
[mark-set continuation-mark-set?]
[key-list (listof any/c)]
[none-v any/c #f]
[prompt-tag continuation-prompt-tag? (default-continuation-prompt-tag)])
(-> (values (or/c vector? #f) procedure?))]{
Like @racket[continuation-mark-set->list*], but instead of returning a
list of values, returns a functional iterator in the form of a
procedure that returns one element of the would-be list and a new
iterator function for the rest of the would-be list. An iterator
procedure returns @racket[#f] instead of a vector when no more
elements are available; in that case, the returned iterator
procedure is like the called one, producing no further values.
The time required for each step is proportional to the length of
@racket[key-list] times the size of the segment of the continuation
reflected by @racket[mark-set] between frames that have keys in
@racket[key-list].
@history[#:added "7.5.0.7"]}
@defproc[(continuation-mark-set-first
[mark-set (or/c continuation-mark-set? #f)]
@ -125,10 +150,12 @@ elements to indicate the lack of a value.}
Returns the first element of the list that would be returned by
@racket[(continuation-mark-set->list (or mark-set
(current-continuation-marks prompt-tag)) key-v prompt-tag)], or
@racket[none-v] if the result would be the empty list. Typically, this
@racket[none-v] if the result would be the empty list. The result
is produced in (amortized) constant time. Typically, this
result can be computed more quickly using
@racket[continuation-mark-set-first] than using
@racket[continuation-mark-set->list].}
@racket[continuation-mark-set->list] or by using
@racket[continuation-mark-set->iterator] and iterating just once.}
@defproc[(call-with-immediate-continuation-mark
[key-v any/c]

29
pkgs/racket-test-core/tests/racket/contmark.rktl
View File

@ -73,6 +73,23 @@
x
x)))))
(wcm-test '(#(no 12) #(10 no))
(lambda ()
(with-continuation-mark 'key1 10
(let ([x (with-continuation-mark 'key2 12
(let loop ([iter (continuation-mark-set->iterator (current-continuation-marks) '(key1 key2) 'no)])
(let-values ([(vec next) (iter)])
(if (not vec)
(let*-values ([(false next-again) (next)]
[(false2 next-again-again) (next-again)])
(test #f values false)
(test #f values false2)
null)
(cons vec (loop next))))))])
(if (void? x)
x
x)))))
(wcm-test '(11) (lambda ()
(with-continuation-mark 'key 10
(with-continuation-mark 'key 11
@ -101,7 +118,7 @@
(with-continuation-mark 'key 10 (extract-current-continuation-marks 'key))
(extract-current-continuation-marks 'key)))))
(require (prefix-in unit: scheme/unit))
(require (prefix-in unit: racket/unit))
;; ;; Hide keywords from scheme/unit.rkt:
(define import #f)
@ -995,6 +1012,14 @@
(current-continuation-marks)
(list mark))))
(define (do-test-iterate mark val)
(with-continuation-mark mark val
(let ([iter (continuation-mark-set->iterator (current-continuation-marks)
(list mark))])
(let loop ([iter iter])
(let-values ([(v iter) (iter)])
(if v (cons v (loop iter)) null))))))
(define (do-test/first mark val)
(with-continuation-mark mark val
(continuation-mark-set-first (current-continuation-marks) mark)))
@ -1006,10 +1031,12 @@
(wcm-test '(12) (lambda () (do-test imp-mark 5)))
(wcm-test '(#(12)) (lambda () (do-test* imp-mark 5)))
(wcm-test '(#(12)) (lambda () (do-test-iterate imp-mark 5)))
(wcm-test 12 (lambda () (do-test/first imp-mark 5)))
(wcm-test 12 (lambda () (do-test/immediate imp-mark 5)))
(wcm-test '(5) (lambda () (do-test cha-mark 5)))
(wcm-test '(#(5)) (lambda () (do-test* cha-mark 5)))
(wcm-test '(#(5)) (lambda () (do-test-iterate cha-mark 5)))
(wcm-test 5 (lambda () (do-test/first cha-mark 5)))
(wcm-test 5 (lambda () (do-test/immediate cha-mark 5)))
(err/rt-test (do-test cha-mark #t) exn:fail?)

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

@ -187,6 +187,7 @@
[cons (known-procedure/pure 4)]
[continuation-mark-key? (known-procedure/pure/folding 2)]
[continuation-mark-set->context (known-procedure/no-prompt 2)]
[continuation-mark-set->iterator (known-procedure/no-prompt 28)]
[continuation-mark-set->list (known-procedure/no-prompt 12)]
[continuation-mark-set->list* (known-procedure/no-prompt 28)]
[continuation-mark-set-first (known-procedure/no-prompt 28)]

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

@ -37,6 +37,7 @@
continuation-mark-set-first
continuation-mark-set->list
continuation-mark-set->list*
continuation-mark-set->iterator
continuation-mark-set->context
current-continuation-marks
(rename [continuation-marks rumble:continuation-marks]) ; wrapped at threads layer

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

@ -1366,51 +1366,74 @@
[(marks keys) (continuation-mark-set->list* marks keys #f the-default-continuation-prompt-tag)]
[(marks keys none-v) (continuation-mark-set->list* marks keys none-v the-default-continuation-prompt-tag)]
[(marks keys none-v prompt-tag)
(check who continuation-mark-set? :or-false marks)
(check who list? keys)
(check who continuation-prompt-tag? prompt-tag)
(maybe-future-barricade prompt-tag)
(let ([prompt-tag (strip-impersonator prompt-tag)])
(let-values ([(all-keys all-wrappers)
(map/2-values (lambda (k)
(extract-continuation-mark-key-and-wrapper 'continuation-mark-set->list* k))
keys)])
(let* ([n (length all-keys)]
[tmp (#%make-vector n)])
(let chain-loop ([mark-chain (or (and marks
(continuation-mark-set-mark-chain marks))
(current-mark-chain))])
(cond
[(null? mark-chain)
null]
[else
(let* ([mcf (elem+cache-strip (car mark-chain))])
(cond
[(eq? (mark-chain-frame-tag mcf) prompt-tag)
null]
[else
(let loop ([marks (mark-chain-frame-marks mcf)])
(cond
[(null? marks)
(chain-loop (cdr mark-chain))]
[else
(let ([t (elem+cache-strip (car marks))])
(let key-loop ([keys all-keys] [wrappers all-wrappers] [i 0] [found? #f])
(cond
[(null? keys)
(if found?
(let ([vec (vector-copy tmp)])
(cons vec (loop (cdr marks))))
(loop (cdr marks)))]
[else
(let ([v (extract-mark-from-frame* t (car keys) none (car wrappers))])
(cond
[(eq? v none)
(vector-set! tmp i none-v)
(key-loop (cdr keys) (cdr wrappers) (add1 i) found?)]
[else
(vector-set! tmp i v)
(key-loop (cdr keys) (cdr wrappers) (add1 i) #t)]))])))]))]))])))))]))
((do-continuation-mark-set->list* who #f marks keys none-v prompt-tag))]))
(define/who continuation-mark-set->iterator
(case-lambda
[(marks keys) (continuation-mark-set->iterator marks keys #f the-default-continuation-prompt-tag)]
[(marks keys none-v) (continuation-mark-set->iterator marks keys none-v the-default-continuation-prompt-tag)]
[(marks keys none-v prompt-tag)
(let ([next (do-continuation-mark-set->list* who #t marks keys none-v prompt-tag)])
;; Each `next` call returns `null` when no more values are
;; available, otherwise a vector and a new next
(lambda ()
(let loop ([next next])
(call-with-values next
(case-lambda
[(done)
(values #f (lambda () (loop (lambda () null))))]
[(v new-next)
(values v (lambda () (loop new-next)))])))))]))
(define (do-continuation-mark-set->list* who iterator? marks keys none-v prompt-tag)
(check who continuation-mark-set? :or-false marks)
(check who list? keys)
(check who continuation-prompt-tag? prompt-tag)
(maybe-future-barricade prompt-tag)
(let ([prompt-tag (strip-impersonator prompt-tag)])
(let-values ([(all-keys all-wrappers)
(map/2-values (lambda (k)
(extract-continuation-mark-key-and-wrapper who k))
keys)])
(lambda ()
(let* ([n (length all-keys)]
[tmp (#%make-vector n)])
(let chain-loop ([mark-chain (or (and marks
(continuation-mark-set-mark-chain marks))
(current-mark-chain))])
(cond
[(null? mark-chain)
null]
[else
(let* ([mcf (elem+cache-strip (car mark-chain))])
(cond
[(eq? (mark-chain-frame-tag mcf) prompt-tag)
null]
[else
(let loop ([marks (mark-chain-frame-marks mcf)])
(cond
[(null? marks)
(chain-loop (cdr mark-chain))]
[else
(let ([t (elem+cache-strip (car marks))])
(let key-loop ([keys all-keys] [wrappers all-wrappers] [i 0] [found? #f])
(cond
[(null? keys)
(if found?
(let ([vec (vector-copy tmp)])
(if iterator?
(values vec (lambda () (loop (cdr marks))))
(cons vec (loop (cdr marks)))))
(loop (cdr marks)))]
[else
(let ([v (extract-mark-from-frame* t (car keys) none (car wrappers))])
(cond
[(eq? v none)
(vector-set! tmp i none-v)
(key-loop (cdr keys) (cdr wrappers) (add1 i) found?)]
[else
(vector-set! tmp i v)
(key-loop (cdr keys) (cdr wrappers) (add1 i) #t)]))])))]))]))])))))))
(define/who (continuation-mark-set->context marks)
(check who continuation-mark-set? marks)

35
racket/src/cs/rumble/error.ss
View File

@ -10,9 +10,10 @@
(do-raise v))]))
(define (do-raise v)
(let ([hs (continuation-mark-set->list (current-continuation-marks/no-trace)
exception-handler-key
the-root-continuation-prompt-tag)]
(let ([get-next-h (continuation-mark-set->iterator (current-continuation-marks/no-trace)
(list exception-handler-key)
#f
the-root-continuation-prompt-tag)]
[init-v (condition->exn v)])
(let ([call-with-nested-handler
(lambda (thunk)
@ -20,20 +21,20 @@
(make-nested-exception-handler "exception handler" init-v)
(lambda ()
(call-with-break-disabled thunk))))])
(let loop ([hs hs] [v init-v])
(cond
[(null? hs)
(call-with-nested-handler
(lambda () (|#%app| (|#%app| uncaught-exception-handler) v)))
;; Use `nested-exception-handler` if the uncaught-exception
;; handler doesn't escape:
((make-nested-exception-handler #f v) #f)]
[else
(let ([h (car hs)]
[hs (cdr hs)])
(let ([new-v (call-with-nested-handler
(lambda () (|#%app| h v)))])
(loop hs new-v)))])))))
(let loop ([get-next-h get-next-h] [v init-v])
(let-values ([(hv get-next-h) (get-next-h)])
(cond
[(not hv)
(call-with-nested-handler
(lambda () (|#%app| (|#%app| uncaught-exception-handler) v)))
;; Use `nested-exception-handler` if the uncaught-exception
;; handler doesn't escape:
((make-nested-exception-handler #f v) #f)]
[else
(let ([h (vector-ref hv 0)])
(let ([new-v (call-with-nested-handler
(lambda () (|#%app| h v)))])
(loop get-next-h new-v)))]))))))
;; ----------------------------------------

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

@ -106,6 +106,7 @@ static Scheme_Object *cont_marks (int argc, Scheme_Object *argv[]);
static Scheme_Object *cc_marks_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_cc_marks (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_cc_markses (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_cc_iterator (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_cc_proc_marks (int argc, Scheme_Object *argv[]);
static Scheme_Object *extract_one_cc_mark (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[]);
@ -415,6 +416,12 @@ scheme_init_fun (Scheme_Startup_Env *env)
2, 4),
env);
scheme_addto_prim_instance("continuation-mark-set->iterator",
scheme_make_prim_w_arity(extract_cc_iterator,
"continuation-mark-set->iterator",
2, 4),
env);
o = scheme_make_prim_w_arity(extract_one_cc_mark,
"continuation-mark-set-first",
2, 4);
@ -8137,59 +8144,23 @@ extract_cc_marks(int argc, Scheme_Object *argv[])
}
static Scheme_Object *
extract_cc_markses(int argc, Scheme_Object *argv[])
iterate_cc_markses(const char *who,
Scheme_Object *prompt_tag, Scheme_Object *none,
intptr_t len, Scheme_Object **keys,
Scheme_Cont_Mark_Chain **_chain)
{
Scheme_Cont_Mark_Chain *chain;
Scheme_Object *first = scheme_null, *last = NULL;
Scheme_Object *pr, **keys, *vals, *none, *prompt_tag;
int len, i;
intptr_t last_pos;
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
scheme_wrong_contract("continuation-mark-set->list*", "continuation-mark-set?", 0, argc, argv);
return NULL;
}
len = scheme_proper_list_length(argv[1]);
if (len < 0) {
scheme_wrong_contract("continuation-mark-set->list*", "list?", 1, argc, argv);
return NULL;
}
if (argc > 2)
none = argv[2];
else
none = scheme_false;
if (argc > 3) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
if (SCHEME_NP_CHAPERONEP(argv[3])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
else {
scheme_wrong_contract("continuation-mark-set->list*", "continuation-prompt-tag?",
3, argc, argv);
return NULL;
}
} else
prompt_tag = argv[3];
} else
prompt_tag = scheme_default_prompt_tag;
keys = MALLOC_N(Scheme_Object *, len);
for (pr = argv[1], i = 0; SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr), i++) {
keys[i] = SCHEME_CAR(pr);
if ((keys[i] == scheme_parameterization_key)
|| (keys[i] == scheme_break_enabled_key)
|| (keys[i] == scheme_exn_handler_key)) {
scheme_signal_error("continuation-mark-set->list: secret key leaked!");
return NULL;
}
}
Scheme_Cont_Mark_Chain *chain = *_chain;
intptr_t last_pos, i;
Scheme_Object *vals = NULL;
prompt_tag = SCHEME_PTR_VAL(prompt_tag);
chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
last_pos = -1;
while (chain) {
if (vals && (last_pos != chain->pos)) {
*_chain = chain;
return vals;
}
for (i = 0; i < len; i++) {
int is_chaperoned = 0;
Scheme_Object *orig_key, *val;
@ -8206,19 +8177,12 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
if (SAME_OBJ(chain->key, keys[i])) {
intptr_t pos;
pos = (intptr_t)chain->pos;
if (pos != last_pos) {
if (!vals) {
vals = scheme_make_vector(len, none);
last_pos = pos;
pr = scheme_make_pair(vals, scheme_null);
if (last)
SCHEME_CDR(last) = pr;
else
first = pr;
last = pr;
} else
vals = SCHEME_CAR(last);
}
if (is_chaperoned) {
val = scheme_chaperone_do_continuation_mark("continuation-mark-set->list*",
val = scheme_chaperone_do_continuation_mark(who,
1, orig_key, chain->val);
SCHEME_VEC_ELS(vals)[i] = val;
} else
@ -8232,7 +8196,125 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
chain = chain->next;
}
return first;
*_chain = NULL;
return vals;
}
static Scheme_Object *iterate_step(void *data, int argc, Scheme_Object *argv[])
{
Scheme_Cont_Mark_Chain *chain = ((void **)data)[0];
void **clos = ((void **)data)[1], **new_state;
Scheme_Object *vals, *a[2];
Scheme_Object *prompt_tag = ((Scheme_Object **)clos)[0];
Scheme_Object **keys = ((Scheme_Object ***)clos)[1];
intptr_t len = SCHEME_INT_VAL(((Scheme_Object **)clos)[2]);
Scheme_Object *none = ((Scheme_Object **)clos)[3];
if (!chain) {
a[0] = scheme_false;
new_state = data;
} else {
vals = iterate_cc_markses("mark-list*-iterator", prompt_tag, none, len, keys, &chain);
if (!vals)
a[0] = scheme_false;
else
a[0] = vals;
new_state = MALLOC_N(void*, 2);
new_state[0] = chain;
new_state[1] = clos;
}
a[1] = scheme_make_closed_prim_w_arity(iterate_step, new_state, "mark-list*-iterator", 0, 0);
return scheme_values(2, a);
}
static Scheme_Object *
do_extract_cc_markses(const char *who, int argc, Scheme_Object *argv[], int iterator)
{
Scheme_Cont_Mark_Chain *chain;
Scheme_Object *first = scheme_null, *last = NULL;
Scheme_Object *pr, **keys, *vals, *none, *prompt_tag;
intptr_t len, i;
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
scheme_wrong_contract(who, "continuation-mark-set?", 0, argc, argv);
return NULL;
}
len = scheme_proper_list_length(argv[1]);
if (len < 0) {
scheme_wrong_contract(who, "list?", 1, argc, argv);
return NULL;
}
if (argc > 2)
none = argv[2];
else
none = scheme_false;
if (argc > 3) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
if (SCHEME_NP_CHAPERONEP(argv[3])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
else {
scheme_wrong_contract(who, "continuation-prompt-tag?",
3, argc, argv);
return NULL;
}
} else
prompt_tag = argv[3];
} else
prompt_tag = scheme_default_prompt_tag;
keys = MALLOC_N(Scheme_Object *, len);
for (pr = argv[1], i = 0; SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr), i++) {
keys[i] = SCHEME_CAR(pr);
if ((keys[i] == scheme_parameterization_key)
|| (keys[i] == scheme_break_enabled_key)) {
scheme_signal_error("%s: misuse of primitive key", who);
return NULL;
}
}
chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
if (iterator) {
void **clos, **state;
clos = MALLOC_N(void*, 4);
clos[0] = prompt_tag;
clos[1] = keys;
clos[2] = scheme_make_integer(len);
clos[3] = none;
state = MALLOC_N(void*, 2);
state[0] = chain;
state[1] = clos;
return scheme_make_closed_prim_w_arity(iterate_step, state, "mark-list*-iterator", 0, 0);
} else {
while (chain) {
vals = iterate_cc_markses(who, prompt_tag, none, len, keys, &chain);
if (vals) {
pr = scheme_make_pair(vals, scheme_null);
if (last)
SCHEME_CDR(last) = pr;
else
first = pr;
last = pr;
}
}
return first;
}
}
static Scheme_Object *
extract_cc_markses(int argc, Scheme_Object *argv[])
{
return do_extract_cc_markses("continuation-mark-set->list*", argc, argv, 0);
}
static Scheme_Object *
extract_cc_iterator(int argc, Scheme_Object *argv[])
{
return do_extract_cc_markses("continuation-mark-set->iterator", argc, argv, 1);
}
Scheme_Object *

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

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1458
#define EXPECTED_PRIM_COUNT 1459
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

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