From 4b120e5d86ae406dec73c7b119ab493ca363adfa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 29 Sep 2010 12:25:51 -0400 Subject: [PATCH] add `proxy-prop:application-mark' --- .../scribblings/reference/chaperones.scrbl | 22 ++++++++- collects/tests/racket/chaperone.rktl | 48 +++++++++++++++++++ src/racket/src/fun.c | 46 +++++++++++++++++- src/racket/src/schpriv.h | 2 + src/racket/src/struct.c | 21 ++++++-- 5 files changed, 134 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/chaperones.scrbl b/collects/scribblings/reference/chaperones.scrbl index 8e285aa8b7..a301035537 100644 --- a/collects/scribblings/reference/chaperones.scrbl +++ b/collects/scribblings/reference/chaperones.scrbl @@ -150,7 +150,20 @@ order of the supplied arguments' keywords. Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments to @scheme[procedure-proxy] must be even) add proxy properties -or override proxy-property values of @scheme[proc].} +or override proxy-property values of @scheme[proc]. + +If any @scheme[prop] is @racket[proxy-prop:application-mark] and if the +associated @racket[prop-val] is a pair, then the call to @racket[proc] +is wrapped with @racket[with-continuation-mark] using @racket[(car +prop-val)] as the mark key and @racket[(cdr prop-val)] as the mark +value. In addition, if @racket[continuation-mark-set-first] with +@racket[(car prop-val)] produces a value for the immediate +continuation frame of the call to the proxied procedure, the value is +also installed as an immediate value for @racket[(car prop-val)] as a +mark during the call to @racket[wrapper-proc] (which allows tail-calls +of proxies with respect to wrapping proxies to be detected within +@racket[wrapper-proc]).} + @defproc[(proxy-struct [v any/c] [orig-proc (or/c struct-accessor-procedure? @@ -537,3 +550,10 @@ descriptor} value, @scheme[#f] otherwise.} Returns @scheme[#t] if @scheme[v] is an accessor procedure produced by @scheme[make-proxy-property], @scheme[#f] otherwise.} + + +@defthing[proxy-prop:application-mark proxy-property?]{ + +A @tech{proxy property} that is recognized by @racket[proxy-procedure] +and @racket[chaperone-procedure].} + diff --git a/collects/tests/racket/chaperone.rktl b/collects/tests/racket/chaperone.rktl index 083df985b9..babd5daa9a 100644 --- a/collects/tests/racket/chaperone.rktl +++ b/collects/tests/racket/chaperone.rktl @@ -1151,4 +1151,52 @@ ;; ---------------------------------------- +(let () + (define (f x) + (call-with-immediate-continuation-mark + 'z + (lambda (val) + (list val + (continuation-mark-set->list (current-continuation-marks) 'z))))) + (define saved null) + (define g (chaperone-procedure + f + (lambda (a) + (set! saved (cons (continuation-mark-set-first #f 'z) + saved)) + (values (lambda (r) r) + a)) + proxy-prop:application-mark + (cons 'z 12))) + (define h (chaperone-procedure + g + (lambda (a) + (values (lambda (r) r) + a)) + proxy-prop:application-mark + (cons 'z 9))) + (define i (chaperone-procedure + f + (lambda (a) + (set! saved (cons (continuation-mark-set-first #f 'z) + saved)) + a) + proxy-prop:application-mark + (cons 'z 11))) + (define j (chaperone-procedure + i + (lambda (a) a) + proxy-prop:application-mark + (cons 'z 12))) + (test (list 12 '(12)) g 10) + (test '(#f) values saved) + (test (list 12 '(12 9)) h 10) + (test '(9 #f) values saved) + (test (list 11 '(11)) i 10) + (test '(#f 9 #f) values saved) + (test (list 11 '(11)) j 10) + (test '(12 #f 9 #f) values saved)) + +;; ---------------------------------------- + (report-errs) diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 7a936eadb7..f8043f8282 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -4174,8 +4174,10 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object { const char *what; Scheme_Chaperone *px; - Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj; + Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj, *app_mark; int c, i, need_restore = 0; + int need_pop_mark = 0; + Scheme_Cont_Frame_Data cframe; if (argv == MZ_RUNSTACK) { /* Pushing onto the runstack ensures that px->redirects won't @@ -4221,6 +4223,26 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object return NULL; } + if (px->props) { + app_mark = scheme_hash_tree_get(px->props, scheme_app_mark_proxy_property); + /* app_mark should be (cons mark val) */ + if (app_mark && !SCHEME_PAIRP(app_mark)) + app_mark = NULL; + } else + app_mark = NULL; + + if (app_mark) { + v = scheme_extract_one_cc_mark(NULL, SCHEME_CAR(app_mark)); + if (v) { + scheme_push_continuation_frame(&cframe); + scheme_set_cont_mark(SCHEME_CAR(app_mark), v); + MZ_CONT_MARK_POS -= 2; + need_pop_mark = 1; + } else + need_pop_mark = 0; + } else + need_pop_mark = 0; + v = _scheme_apply_multi(px->redirects, argc, argv); if (v == SCHEME_MULTIPLE_VALUES) { GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread; @@ -4233,6 +4255,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object a2[0] = v; argv2 = a2; } + + if (need_pop_mark) { + MZ_CONT_MARK_POS += 2; + scheme_pop_continuation_frame(&cframe); + } if ((c == argc) || (c == (argc + 1))) { if (c > argc) { @@ -4278,6 +4305,8 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object if (c == argc) { /* No filter for the result, so tail call: */ + if (app_mark) + scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark)); if (auto_val) { if (SCHEME_CHAPERONEP(px->prev)) return do_apply_chaperone(px->prev, c, argv2, auto_val); @@ -4299,6 +4328,15 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object what, px->redirects, post); + + if (app_mark) { + scheme_push_continuation_frame(&cframe); + scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark)); + MZ_CONT_MARK_POS -= 2; + need_pop_mark = 1; + } else + need_pop_mark = 0; + if (auto_val) { if (SCHEME_CHAPERONEP(px->prev)) result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val); @@ -4314,6 +4352,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object v = _scheme_apply_multi(orig_obj, argc, argv2); result_v = NULL; } + if (v == SCHEME_MULTIPLE_VALUES) { GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread; if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) @@ -4325,6 +4364,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object a[0] = v; argv = a; } + + if (need_pop_mark) { + MZ_CONT_MARK_POS += 2; + scheme_pop_continuation_frame(&cframe); + } if (!scheme_check_proc_arity(NULL, c, 0, -1, &post)) scheme_raise_exn(MZEXN_FAIL_CONTRACT, diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index a54a238c76..d81321ddf8 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -386,6 +386,8 @@ extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property; extern Scheme_Object *scheme_equal_property; extern Scheme_Object *scheme_proxy_of_property; +extern Scheme_Object *scheme_app_mark_proxy_property; + extern Scheme_Object *scheme_reduced_procedure_struct; /*========================================================================*/ diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 8225f14480..720dcbd5cf 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -38,6 +38,7 @@ READ_ONLY Scheme_Object *scheme_current_inspector_proc; READ_ONLY Scheme_Object *scheme_recur_symbol; READ_ONLY Scheme_Object *scheme_display_symbol; READ_ONLY Scheme_Object *scheme_write_special_symbol; +READ_ONLY Scheme_Object *scheme_app_mark_proxy_property; READ_ONLY static Scheme_Object *location_struct; READ_ONLY static Scheme_Object *write_property; @@ -170,6 +171,8 @@ static Scheme_Object *proxy_struct(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv); static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]); +static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name); + #define PRE_REDIRECTS 2 #ifdef MZ_PRECISE_GC @@ -722,9 +725,13 @@ scheme_init_struct (Scheme_Env *env) 1, 1, 1), env); - scheme_add_global_constant("proxy-prop:application-mark", - scheme_false, - env); + { + REGISTER_SO(scheme_app_mark_proxy_property); + scheme_app_mark_proxy_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark")); + scheme_add_global_constant("proxy-prop:application-mark", + scheme_app_mark_proxy_property, + env); + } } /*========================================================================*/ @@ -1104,6 +1111,14 @@ static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]) return scheme_values(3, a); } +static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name) +{ + Scheme_Object *a[3]; + + a[0] = name; + return make_struct_type_property_from_c(1, a, &a[1], &a[2], scheme_chaperone_property_type); +} + Scheme_Object *scheme_make_struct_type_property_w_guard(Scheme_Object *name, Scheme_Object *guard) { Scheme_Object *a[2];