fix problems with continuation-mark-key chaperones
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
parent
87d84a59c1
commit
73eeff4f60
|
|
@ -1074,6 +1074,29 @@
|
|||
(err/rt-test (do-test bad-mark 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
|
||||
;; capture metacontinuations
|
||||
|
|
|
|||
|
|
@ -3953,7 +3953,7 @@
|
|||
(define (f v)
|
||||
(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
|
||||
(require racket/unsafe/ops)
|
||||
(struct a (x y))
|
||||
|
|
@ -3965,7 +3965,8 @@
|
|||
(define (f v)
|
||||
(list (a-x v) #t))))
|
||||
|
||||
(test-comp '(module m racket/base
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(module m racket/base
|
||||
(require racket/unsafe/ops)
|
||||
(struct a (x y))
|
||||
(struct b a (z))
|
||||
|
|
@ -3978,7 +3979,8 @@
|
|||
(define (f v)
|
||||
(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)
|
||||
(struct a (x y))
|
||||
(struct b a (z))
|
||||
|
|
@ -3991,7 +3993,8 @@
|
|||
(define (f v)
|
||||
(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
|
||||
racket/unsafe/ops)
|
||||
(struct c b (m))
|
||||
|
|
@ -4022,7 +4025,8 @@
|
|||
(a? (a-x (a 1 2)))
|
||||
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)
|
||||
|
||||
(procedure? a)
|
||||
|
|
@ -4098,13 +4102,15 @@
|
|||
#t
|
||||
(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)
|
||||
10)
|
||||
'(lambda ()
|
||||
10))
|
||||
|
||||
(test-comp '(lambda ()
|
||||
(test-comp #:except 'chez-scheme ; not able to remove pure `make-struct-type-property`
|
||||
'(lambda ()
|
||||
(make-struct-type-property 'a)
|
||||
10)
|
||||
'(lambda ()
|
||||
|
|
@ -4121,7 +4127,8 @@
|
|||
'(lambda () 5)
|
||||
#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))
|
||||
(lambda (x)
|
||||
(a? x)
|
||||
|
|
@ -4130,7 +4137,8 @@
|
|||
(define-values (prop:a a? a-ref) (make-struct-type-property 'a))
|
||||
(lambda (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))
|
||||
|
||||
(procedure? a?)
|
||||
|
|
@ -4168,10 +4176,10 @@
|
|||
(struct b () #:property prop:a 'a)
|
||||
(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))
|
||||
;; 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))
|
||||
(struct b () #:property prop:a 'a)
|
||||
(define (g y) (list y)))
|
||||
|
|
@ -4179,8 +4187,7 @@
|
|||
(define (f x) (list (list x) g))
|
||||
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error))
|
||||
(struct b () #:property prop:a 'a)
|
||||
(define (g y) (list y)))
|
||||
#f)
|
||||
(define (g y) (list y))))
|
||||
|
||||
(test-comp '(lambda ()
|
||||
;; The built-in `prop:object-name` property has a guard:
|
||||
|
|
@ -4189,9 +4196,10 @@
|
|||
'(lambda () 5)
|
||||
#f)
|
||||
|
||||
(module struct-type-property-a racket/base
|
||||
(provide prop:a)
|
||||
(define-values (prop:a a? a-ref) (make-struct-type-property 'a)))
|
||||
(register-top-level-module
|
||||
(module struct-type-property-a racket/base
|
||||
(provide prop:a)
|
||||
(define-values (prop:a a? a-ref) (make-struct-type-property 'a))))
|
||||
|
||||
(test-comp '(module m racket/base
|
||||
(require 'struct-type-property-a)
|
||||
|
|
@ -4204,11 +4212,13 @@
|
|||
(struct b () #:property prop:a 'a)
|
||||
(define (g y) (list y))))
|
||||
|
||||
(module struct-type-property-a-with-guard racket/base
|
||||
(provide prop:a)
|
||||
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error)))
|
||||
(register-top-level-module
|
||||
(module struct-type-property-a-with-guard racket/base
|
||||
(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)
|
||||
(define (f x) (list (g x) g))
|
||||
(struct b () #:property prop:a 'a)
|
||||
|
|
@ -4217,10 +4227,10 @@
|
|||
(require 'struct-type-property-a-with-guard)
|
||||
(define (f x) (list (list x) g))
|
||||
(struct b () #:property prop:a 'a)
|
||||
(define (g y) (list y)))
|
||||
#f)
|
||||
(define (g y) (list y))))
|
||||
|
||||
(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)
|
||||
(let ()
|
||||
;; Should be able to tell that `struct:posn` is prefab
|
||||
|
|
@ -4277,6 +4287,16 @@
|
|||
(with-continuation-mark 'x (values 1 2) (list 1)))
|
||||
#f)
|
||||
(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
|
||||
x 1
|
||||
(with-continuation-mark
|
||||
|
|
@ -4285,27 +4305,28 @@
|
|||
`(lambda (x)
|
||||
(with-continuation-mark
|
||||
x 2
|
||||
(x))))
|
||||
(x)))
|
||||
#f)
|
||||
(test-comp `(lambda (x)
|
||||
(with-continuation-mark
|
||||
x (display x)
|
||||
'x (display x)
|
||||
(with-continuation-mark
|
||||
x 2
|
||||
'x 2
|
||||
(x))))
|
||||
`(lambda (x)
|
||||
(display x)
|
||||
(with-continuation-mark
|
||||
x 2
|
||||
'x 2
|
||||
(x))))
|
||||
(test-comp `(lambda (x)
|
||||
(with-continuation-mark
|
||||
x 1
|
||||
'x 1
|
||||
(with-continuation-mark
|
||||
x (current-continuation-marks)
|
||||
'x (current-continuation-marks)
|
||||
(x))))
|
||||
`(lambda (x)
|
||||
(with-continuation-mark
|
||||
x (current-continuation-marks)
|
||||
'x (current-continuation-marks)
|
||||
(x)))
|
||||
#f)
|
||||
(test-comp '(lambda (v)
|
||||
|
|
|
|||
|
|
@ -530,7 +530,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
|
|||
if (!(flags & OMITTABLE_KEEP_VARS)
|
||||
&& ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_READY))
|
||||
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;
|
||||
else
|
||||
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_Object *k, *v, *b;
|
||||
int init_vclock;
|
||||
int init_vclock, can_omit_key;
|
||||
Optimize_Info_Sequence 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
|
||||
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))
|
||||
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>
|
||||
<body>))
|
||||
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)
|
||||
&& 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);
|
||||
|
|
|
|||
|
|
@ -998,7 +998,7 @@
|
|||
[(pair? a)
|
||||
(if (eq? key (car a))
|
||||
(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))]
|
||||
[(eq? a 'empty)
|
||||
;; 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))
|
||||
'empty]
|
||||
[(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))]
|
||||
[else
|
||||
;; assert: (elem+cache? a)
|
||||
|
|
@ -1578,7 +1578,7 @@
|
|||
(authentic-continuation-mark-key? (impersonator-val v)))))
|
||||
|
||||
;; 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
|
||||
[(and (impersonator? k)
|
||||
(authentic-continuation-mark-key? (impersonator-val k)))
|
||||
|
|
@ -1586,14 +1586,20 @@
|
|||
(cond
|
||||
[(or (continuation-mark-key-impersonator? k)
|
||||
(continuation-mark-key-chaperone? k))
|
||||
(let ([new-v (|#%app|
|
||||
(if (continuation-mark-key-impersonator? k)
|
||||
(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))
|
||||
(let ([new-v
|
||||
;; Restore attachment while interposing
|
||||
(call-setting-continuation-attachment
|
||||
old-a
|
||||
(lambda ()
|
||||
(let ([new-v (|#%app|
|
||||
(if (continuation-mark-key-impersonator? k)
|
||||
(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))]
|
||||
[(impersonator? k)
|
||||
(loop (impersonator-next k) v)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user