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

fix problems with continuation-mark-key chaperones

Browse Source 
CS: When `with-continuation-mark` for a chaperoned key is in tail
position for a mark (such as a `parameterize`), make sure the existing
mark is still in place while (non-tail-)calling the chaperone's
interposition function.

BC: Don't collapse immediately nested `with-continuation-mark`s for
the same key if the key might be chaperoned. Also, repair treatment of
module-level bindings as potentially chaperoned.
This commit is contained in:
Matthew Flatt 2021-03-07 20:08:49 -07:00
parent 87d84a59c1
commit 73eeff4f60
4 changed files with 98 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1074,6 +1074,29 @@
(err/rt-test (do-test bad-mark 5) exn:fail?) (err/rt-test (do-test bad-mark 5) exn:fail?)
(err/rt-test (do-test bad-mark-2 5) exn:fail?)) (err/rt-test (do-test bad-mark-2 5) exn:fail?))
;; Make sure chaperoned keys are not collapsed, and make sure
;; parameters are in place for a chaperone invoked for a mark
;; that is in tail position with respect to `parameterize`
(module regression-test-for-chaperoned-keys racket/base
(provide f)
(define key
(chaperone-continuation-mark-key
(make-continuation-mark-key)
(lambda (v) (printf "get\n") v)
(lambda (v) (printf "set\n") v)))
(define (f)
(with-continuation-mark
key 1
(with-continuation-mark
key 2
'ok))))
(let ([o (open-output-bytes)])
(let ([f (dynamic-require ''regression-test-for-chaperoned-keys 'f)])
(parameterize ([current-output-port o])
(f)))
(test #"set\nset\n" get-output-bytes o))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that caching works right for marks in continuations that ;; Check that caching works right for marks in continuations that
;; capture metacontinuations ;; capture metacontinuations

83
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -3953,7 +3953,7 @@
(define (f v) (define (f v)
(list (a-x v) #t)))) (list (a-x v) #t))))
(test-comp #:except 'chez-scheme (test-comp #:except 'chez-scheme ; cptypes can't see through chaperone support
'(module m racket/base '(module m racket/base
(require racket/unsafe/ops) (require racket/unsafe/ops)
(struct a (x y)) (struct a (x y))
@ -3965,7 +3965,8 @@
(define (f v) (define (f v)
(list (a-x v) #t)))) (list (a-x v) #t))))
(test-comp '(module m racket/base (test-comp #:except 'chez-scheme
'(module m racket/base
(require racket/unsafe/ops) (require racket/unsafe/ops)
(struct a (x y)) (struct a (x y))
(struct b a (z)) (struct b a (z))
@ -3978,7 +3979,8 @@
(define (f v) (define (f v)
(and (b? v) (unsafe-struct-ref v 2))))) (and (b? v) (unsafe-struct-ref v 2)))))
(test-comp '(module m racket/base (test-comp #:except 'chez-scheme
'(module m racket/base
(require racket/unsafe/ops) (require racket/unsafe/ops)
(struct a (x y)) (struct a (x y))
(struct b a (z)) (struct b a (z))
@ -3991,7 +3993,8 @@
(define (f v) (define (f v)
(list (b-z v) #t)))) (list (b-z v) #t))))
(test-comp '(module m racket/base (test-comp #:except 'chez-scheme
'(module m racket/base
(require 'struct-a-for-optimize (require 'struct-a-for-optimize
racket/unsafe/ops) racket/unsafe/ops)
(struct c b (m)) (struct c b (m))
@ -4022,7 +4025,8 @@
(a? (a-x (a 1 2))) (a? (a-x (a 1 2)))
5))) 5)))
(test-comp '(module m racket/base (test-comp #:except 'chez-scheme ; `procedure?` is not primitive enough
'(module m racket/base
(struct a (x) #:omit-define-syntaxes #:mutable) (struct a (x) #:omit-define-syntaxes #:mutable)
(procedure? a) (procedure? a)
@ -4098,13 +4102,15 @@
#t #t
(lambda (x) (set-a-x! x 5)))) (lambda (x) (set-a-x! x 5))))
(test-comp '(lambda () (test-comp #:except 'chez-scheme ; not able to remove pure `make-struct-type`
'(lambda ()
(make-struct-type 'a #f 0 0 #f) (make-struct-type 'a #f 0 0 #f)
10) 10)
'(lambda () '(lambda ()
10)) 10))
(test-comp '(lambda () (test-comp #:except 'chez-scheme ; not able to remove pure `make-struct-type-property`
'(lambda ()
(make-struct-type-property 'a) (make-struct-type-property 'a)
10) 10)
'(lambda () '(lambda ()
@ -4121,7 +4127,8 @@
'(lambda () 5) '(lambda () 5)
#f) #f)
(test-comp '(module m racket/base (test-comp #:except 'chez-scheme
'(module m racket/base
(define-values (prop:a a? a-ref) (make-struct-type-property 'a)) (define-values (prop:a a? a-ref) (make-struct-type-property 'a))
(lambda (x) (lambda (x)
(a? x) (a? x)
@ -4130,7 +4137,8 @@
(define-values (prop:a a? a-ref) (make-struct-type-property 'a)) (define-values (prop:a a? a-ref) (make-struct-type-property 'a))
(lambda (x) (lambda (x)
x))) x)))
(test-comp '(module m racket/base (test-comp #:except 'chez-scheme
'(module m racket/base
(define-values (prop:a a? a-ref) (make-struct-type-property 'a)) (define-values (prop:a a? a-ref) (make-struct-type-property 'a))
(procedure? a?) (procedure? a?)
@ -4168,10 +4176,10 @@
(struct b () #:property prop:a 'a) (struct b () #:property prop:a 'a)
(define (g y) (list y)))) (define (g y) (list y))))
(test-comp '(module m racket/base (test-comp #:except 'racket ; a property type with a guard inhibits inlining, because the
;; guard might raise an error
'(module m racket/base
(define (f x) (list (g x) g)) (define (f x) (list (g x) g))
;; A property type with a guard inhibits inlining, because the
;; guard might raise an error
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error)) (define-values (prop:a a? a-ref) (make-struct-type-property 'a error))
(struct b () #:property prop:a 'a) (struct b () #:property prop:a 'a)
(define (g y) (list y))) (define (g y) (list y)))
@ -4179,8 +4187,7 @@
(define (f x) (list (list x) g)) (define (f x) (list (list x) g))
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error)) (define-values (prop:a a? a-ref) (make-struct-type-property 'a error))
(struct b () #:property prop:a 'a) (struct b () #:property prop:a 'a)
(define (g y) (list y))) (define (g y) (list y))))
#f)
(test-comp '(lambda () (test-comp '(lambda ()
;; The built-in `prop:object-name` property has a guard: ;; The built-in `prop:object-name` property has a guard:
@ -4189,9 +4196,10 @@
'(lambda () 5) '(lambda () 5)
#f) #f)
(module struct-type-property-a racket/base (register-top-level-module
(provide prop:a) (module struct-type-property-a racket/base
(define-values (prop:a a? a-ref) (make-struct-type-property 'a))) (provide prop:a)
(define-values (prop:a a? a-ref) (make-struct-type-property 'a))))
(test-comp '(module m racket/base (test-comp '(module m racket/base
(require 'struct-type-property-a) (require 'struct-type-property-a)
@ -4204,11 +4212,13 @@
(struct b () #:property prop:a 'a) (struct b () #:property prop:a 'a)
(define (g y) (list y)))) (define (g y) (list y))))
(module struct-type-property-a-with-guard racket/base (register-top-level-module
(provide prop:a) (module struct-type-property-a-with-guard racket/base
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error))) (provide prop:a)
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error))))
(test-comp '(module m racket/base (test-comp #:except 'racket ; a property type with a guard inhibits inlining
'(module m racket/base
(require 'struct-type-property-a-with-guard) (require 'struct-type-property-a-with-guard)
(define (f x) (list (g x) g)) (define (f x) (list (g x) g))
(struct b () #:property prop:a 'a) (struct b () #:property prop:a 'a)
@ -4217,10 +4227,10 @@
(require 'struct-type-property-a-with-guard) (require 'struct-type-property-a-with-guard)
(define (f x) (list (list x) g)) (define (f x) (list (list x) g))
(struct b () #:property prop:a 'a) (struct b () #:property prop:a 'a)
(define (g y) (list y))) (define (g y) (list y))))
#f)
(test-comp '(module m racket/base (test-comp #:except 'chez-scheme ; not able to remove pure `make-struct-type`
'(module m racket/base
(struct posn (x y) #:prefab) (struct posn (x y) #:prefab)
(let () (let ()
;; Should be able to tell that `struct:posn` is prefab ;; Should be able to tell that `struct:posn` is prefab
@ -4277,6 +4287,16 @@
(with-continuation-mark 'x (values 1 2) (list 1))) (with-continuation-mark 'x (values 1 2) (list 1)))
#f) #f)
(test-comp `(lambda (x) (test-comp `(lambda (x)
(with-continuation-mark
'x 1
(with-continuation-mark
'x 2
(x))))
`(lambda (x)
(with-continuation-mark
'x 2
(x))))
(test-comp `(lambda (x) ; `x` might be chaperoned
(with-continuation-mark (with-continuation-mark
x 1 x 1
(with-continuation-mark (with-continuation-mark
@ -4285,27 +4305,28 @@
`(lambda (x) `(lambda (x)
(with-continuation-mark (with-continuation-mark
x 2 x 2
(x)))) (x)))
#f)
(test-comp `(lambda (x) (test-comp `(lambda (x)
(with-continuation-mark (with-continuation-mark
x (display x) 'x (display x)
(with-continuation-mark (with-continuation-mark
x 2 'x 2
(x)))) (x))))
`(lambda (x) `(lambda (x)
(display x) (display x)
(with-continuation-mark (with-continuation-mark
x 2 'x 2
(x)))) (x))))
(test-comp `(lambda (x) (test-comp `(lambda (x)
(with-continuation-mark (with-continuation-mark
x 1 'x 1
(with-continuation-mark (with-continuation-mark
x (current-continuation-marks) 'x (current-continuation-marks)
(x)))) (x))))
`(lambda (x) `(lambda (x)
(with-continuation-mark (with-continuation-mark
x (current-continuation-marks) 'x (current-continuation-marks)
(x))) (x)))
#f) #f)
(test-comp '(lambda (v) (test-comp '(lambda (v)

10
racket/src/bc/src/optimize.c
View File

@ -530,7 +530,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
if (!(flags & OMITTABLE_KEEP_VARS) if (!(flags & OMITTABLE_KEEP_VARS)
&& ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_READY)) && ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_READY))
return 1; return 1;
else if ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) else if ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST)
return 1; return 1;
else else
return 0; return 0;
@ -6296,7 +6296,7 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co
{ {
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b; Scheme_Object *k, *v, *b;
int init_vclock; int init_vclock, can_omit_key;
Optimize_Info_Sequence info_seq; Optimize_Info_Sequence info_seq;
optimize_info_seq_init(info, &info_seq); optimize_info_seq_init(info, &info_seq);
@ -6337,7 +6337,8 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co
/* If the body cannot inspect the continution, and if the key is not /* If the body cannot inspect the continution, and if the key is not
a chaperone, no need to add the mark: */ a chaperone, no need to add the mark: */
if (omittable_key(k, info) can_omit_key = omittable_key(k, info);
if (can_omit_key
&& scheme_omittable_expr(b, -1, 20, 0, info, info)) && scheme_omittable_expr(b, -1, 20, 0, info, info))
return make_discarding_first_sequence(v, b, info); return make_discarding_first_sequence(v, b, info);
@ -6358,7 +6359,8 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co
(with-continuation-mark <same-key> <val2> (with-continuation-mark <same-key> <val2>
<body>)) <body>))
as long as <val2> doesn't inspect the continuation. */ as long as <val2> doesn't inspect the continuation. */
if (SAME_TYPE(SCHEME_TYPE(wcm->body), scheme_with_cont_mark_type) if (can_omit_key
&& SAME_TYPE(SCHEME_TYPE(wcm->body), scheme_with_cont_mark_type)
&& equivalent_exprs(wcm->key, ((Scheme_With_Continuation_Mark *)wcm->body)->key, NULL, NULL, 0) && equivalent_exprs(wcm->key, ((Scheme_With_Continuation_Mark *)wcm->body)->key, NULL, NULL, 0)
&& scheme_omittable_expr(((Scheme_With_Continuation_Mark *)wcm->body)->val, 1, 20, 0, info, info)) && scheme_omittable_expr(((Scheme_With_Continuation_Mark *)wcm->body)->val, 1, 20, 0, info, info))
return make_discarding_first_sequence(wcm->val, wcm->body, info); return make_discarding_first_sequence(wcm->val, wcm->body, info);

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

@ -998,7 +998,7 @@
[(pair? a) [(pair? a)
(if (eq? key (car a)) (if (eq? key (car a))
(cons key val) (cons key val)
(make-mark-frame (mark-table-add/replace* (pair->mark-table a) key val) (make-mark-frame (mark-table-add/replace* (pair->mark-table a) a key val)
#f))] #f))]
[(eq? a 'empty) [(eq? a 'empty)
;; The current frame is the mark-splice frame, so update ;; The current frame is the mark-splice frame, so update
@ -1006,7 +1006,7 @@
(current-mark-splice (mark-frame-update (current-mark-splice) key val)) (current-mark-splice (mark-frame-update (current-mark-splice) key val))
'empty] 'empty]
[(mark-frame? a) [(mark-frame? a)
(make-mark-frame (mark-table-add/replace* (mark-frame-table a) key val) (make-mark-frame (mark-table-add/replace* (mark-frame-table a) a key val)
(mark-frame-end-uninterupted? a))] (mark-frame-end-uninterupted? a))]
[else [else
;; assert: (elem+cache? a) ;; assert: (elem+cache? a)
@ -1578,7 +1578,7 @@
(authentic-continuation-mark-key? (impersonator-val v))))) (authentic-continuation-mark-key? (impersonator-val v)))))
;; Like `mark-table-add/replace`, but handles continuation-mark-key impersonators ;; Like `mark-table-add/replace`, but handles continuation-mark-key impersonators
(define (mark-table-add/replace* ht k v) (define (mark-table-add/replace* ht old-a k v)
(cond (cond
[(and (impersonator? k) [(and (impersonator? k)
(authentic-continuation-mark-key? (impersonator-val k))) (authentic-continuation-mark-key? (impersonator-val k)))
@ -1586,14 +1586,20 @@
(cond (cond
[(or (continuation-mark-key-impersonator? k) [(or (continuation-mark-key-impersonator? k)
(continuation-mark-key-chaperone? k)) (continuation-mark-key-chaperone? k))
(let ([new-v (|#%app| (let ([new-v
(if (continuation-mark-key-impersonator? k) ;; Restore attachment while interposing
(continuation-mark-key-impersonator-set k) (call-setting-continuation-attachment
(continuation-mark-key-chaperone-set k)) old-a
v)]) (lambda ()
(unless (or (continuation-mark-key-impersonator? k) (let ([new-v (|#%app|
(chaperone-of? new-v v)) (if (continuation-mark-key-impersonator? k)
(raise-chaperone-error 'with-continuation-mark "value" v new-v)) (continuation-mark-key-impersonator-set k)
(continuation-mark-key-chaperone-set k))
v)])
(unless (or (continuation-mark-key-impersonator? k)
(chaperone-of? new-v v))
(raise-chaperone-error 'with-continuation-mark "value" v new-v))
new-v)))])
(loop (impersonator-next k) new-v))] (loop (impersonator-next k) new-v))]
[(impersonator? k) [(impersonator? k)
(loop (impersonator-next k) v)] (loop (impersonator-next k) v)]