From f9a69105bc23a15a6dde61aeec073b4ed7e3eeb1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Oct 2018 18:14:50 -0400 Subject: [PATCH] cs: small repairs for chaperones The "struct.rktl" and "chaperone.rktl" tests now pass. --- .../tests/racket/chaperone.rktl | 44 +++++++----- racket/src/cs/demo/chaperone.ss | 2 +- racket/src/cs/rumble/equal.ss | 6 +- racket/src/cs/rumble/hash.ss | 67 +++++++++++++----- racket/src/cs/rumble/impersonator.ss | 68 +++++++++++++------ racket/src/cs/rumble/intmap.ss | 2 +- racket/src/cs/rumble/procedure.ss | 27 ++++---- 7 files changed, 142 insertions(+), 74 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index 80b3592ead..0232b6d4e8 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -9,6 +9,8 @@ unsafe-impersonate-procedure unsafe-chaperone-procedure)) +(define secondary-hash-unused? (eq? 'cs (system-type 'gc))) + ;; ---------------------------------------- (define (chaperone-of?/impersonator a b) @@ -116,8 +118,9 @@ (test "bad get" exn-message exn))) (err/rt-test (equal-hash-code b2) (lambda (exn) (test "bad get" exn-message exn))) - (err/rt-test (equal-secondary-hash-code b2) (lambda (exn) - (test "bad get" exn-message exn))) + (unless secondary-hash-unused? + (err/rt-test (equal-secondary-hash-code b2) (lambda (exn) + (test "bad get" exn-message exn)))) (err/rt-test (equal? b2 (box 'bad)) (lambda (exn) (test "bad get" exn-message exn))) (test (void) set-box! b 'ok) @@ -1563,9 +1566,10 @@ [c1 (chaperone-struct (c 1) c-n (lambda (b v) (set! got? #t) v))]) (void (equal-hash-code c1)) (test #t values got?) - (set! got? #f) - (void (equal-secondary-hash-code c1)) - (test #t values got?) + (unless secondary-hash-unused? + (set! got? #f) + (void (equal-secondary-hash-code c1)) + (test #t values got?)) (define c3 (c 1)) (set! got? #f) (void (equal? c1 c3)) @@ -1589,10 +1593,11 @@ set-d-n! (lambda (b v) v))) (void (equal-hash-code d1)) (test '(#t #t) list got? mine?) - (set! got? #f) - (set! mine? #f) - (void (equal-secondary-hash-code d1)) - (test '(#t #t) list got? mine?) + (unless secondary-hash-unused? + (set! got? #f) + (set! mine? #f) + (void (equal-secondary-hash-code d1)) + (test '(#t #t) list got? mine?)) (define d3 (d 1)) (set! got? #f) (set! mine? #f) @@ -1611,9 +1616,10 @@ (define d1 (chaperone-struct (d 1) d-n (lambda (b v) (set! got? #t) v))) (void (equal-hash-code d1)) (test '(#t) list got?) - (set! got? #f) - (void (equal-secondary-hash-code d1)) - (test '(#t) list got?) + (unless secondary-hash-unused? + (set! got? #f) + (void (equal-secondary-hash-code d1)) + (test '(#t) list got?)) (define d3 (d 1)) (set! got? #f) (test #t values (equal? d1 d3)) @@ -1961,9 +1967,10 @@ (set! get-v #f) (void (equal-hash-code h2)) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) - (set! get-k #f) - (set! get-v #f) - (void (equal-secondary-hash-code h2)) + (unless secondary-hash-unused? + (set! get-k #f) + (set! get-v #f) + (void (equal-secondary-hash-code h2))) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) (set! get-k #f) (set! get-v #f) @@ -2031,9 +2038,10 @@ (set! get-v #f) (void (equal-hash-code h2)) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) - (set! get-k #f) - (set! get-v #f) - (void (equal-secondary-hash-code h2)) + (unless secondary-hash-unused? + (set! get-k #f) + (set! get-v #f) + (void (equal-secondary-hash-code h2))) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) (set! get-k #f) (set! get-v #f) diff --git a/racket/src/cs/demo/chaperone.ss b/racket/src/cs/demo/chaperone.ss index 7f0bc3fb5a..f0d3e84516 100644 --- a/racket/src/cs/demo/chaperone.ss +++ b/racket/src/cs/demo/chaperone.ss @@ -348,7 +348,7 @@ (check (ops!) '(set equal-key)) (check (hash-ref (hash-remove ht1c 1) 1 'none) 'none) - (check (ops!) '(remove equal-key get equal-key)) + (check (ops!) '(remove equal-key get equal-key equal-key)) (check (begin (hash-remove! ht2c 1) (hash-ref ht2c 1 'none)) diff --git a/racket/src/cs/rumble/equal.ss b/racket/src/cs/rumble/equal.ss index 0f2d045849..ecd4da07f5 100644 --- a/racket/src/cs/rumble/equal.ss +++ b/racket/src/cs/rumble/equal.ss @@ -89,7 +89,7 @@ (equal? (unbox orig-a) (unbox orig-b) ctx)))))] [(record? a) (and (record? b) - ;; Check for for `prop:impersonator-of` + ;; Check for `prop:impersonator-of` (let ([a2 (and (not (eq? mode 'chaperone-of?)) (extract-impersonator-of mode a))] [b2 (and (eq? mode 'equal?) @@ -100,7 +100,7 @@ ;; other forms of checking (or (check-union-find ctx a b) (let ([ctx (deeper-context ctx)]) - (equal? (or a a2) (or b b2) ctx)))] + (equal? (or a2 a) (or b2 b) ctx)))] [else ;; No `prop:impersonator-of`, so check for ;; `prop:equal+hash` or transparency @@ -135,7 +135,7 @@ (define/who (equal?/recur a b eql?) (check who (procedure-arity-includes/c 2) eql?) - (do-equal? a b 'equal?/recur eql?)) + (do-equal? a b 'equal? eql?)) ;; ---------------------------------------- diff --git a/racket/src/cs/rumble/hash.ss b/racket/src/cs/rumble/hash.ss index 3fd114daef..53e958dcee 100644 --- a/racket/src/cs/rumble/hash.ss +++ b/racket/src/cs/rumble/hash.ss @@ -129,7 +129,12 @@ (let ([ht (impersonator-val ht)]) (or (mutable-hash? ht) (weak-equal-hash? ht)))) - (impersonate-hash-clear! ht)] + (unless (impersonate-hash-clear ht #t) + ;; fall back to iterated remove + (let loop ([i (hash-iterate-first ht)]) + (when i + (hash-remove! ht (hash-iterate-key ht i)) + (loop (hash-iterate-next ht i)))))] [else (raise-argument-error 'hash-clear! "(and/c hash? (not/c immutable?))" ht)])) (define (hash-copy ht) @@ -185,11 +190,13 @@ [else empty-hash])] [(and (impersonator? ht) (intmap? (impersonator-val ht))) - (let loop ([ht ht]) - (let ([i (hash-iterate-first ht)]) - (if i - (loop (hash-remove ht (hash-iterate-key ht i))) - ht)))] + (or (impersonate-hash-clear ht #f) + ;; fall back to iterated remove + (let loop ([ht ht]) + (let ([i (hash-iterate-first ht)]) + (if i + (loop (hash-remove ht (hash-iterate-key ht i))) + ht))))] [else (raise-argument-error 'hash-clear! "(and/c hash? immutable?)" ht)])) (define (hash-eq? ht) @@ -963,16 +970,20 @@ (check who (procedure-arity-includes/c 2) key) (let* ([clear-given? (and (pair? args) (or (not (car args)) - (and (procedure? (car args)) - (procedure-arity-includes? (car args) 1))))] - [clear (if clear-given? (car args) void)] + (procedure? (car args))))] + [clear (if clear-given? + (let ([clear (car args)]) + (check who (procedure-arity-includes/c 1) :or-false clear) + clear) + void)] [args (if clear-given? (cdr args) args)] [equal-key-given? (and (pair? args) (or (not (car args)) - (and (procedure? (car args)) - (procedure-arity-includes? (car args) 2))))] + (procedure? (car args))))] [equal-key (if equal-key-given? - (car args) + (let ([equal-key (car args)]) + (check who (procedure-arity-includes/c 2) :or-false equal-key) + equal-key) (lambda (ht k) k))] [args (if equal-key-given? (cdr args) args)]) (make-hash-chaperone (strip-impersonator ht) @@ -1103,7 +1114,7 @@ (raise-chaperone-error who "key" new-k k)) new-k))) -(define (impersonate-hash-clear! ht) +(define (impersonate-hash-clear ht mutable?) (let loop ([ht ht]) (cond [(or (hash-impersonator? ht) @@ -1111,13 +1122,33 @@ (let ([procs (if (hash-impersonator? ht) (hash-impersonator-procs ht) (hash-chaperone-procs ht))] - [ht (impersonator-next ht)]) - ((hash-procs-clear procs) ht) - (loop ht))] + [next-ht (impersonator-next ht)]) + (let ([clear (hash-procs-clear procs)]) + (cond + [clear + (clear next-ht) + (if mutable? + (loop next-ht) + (let ([r (loop next-ht)]) + (and r + ((if (chaperone? ht) make-hash-chaperone make-hash-impersonator) + (strip-impersonator r) + r + (impersonator-props ht) + procs))))] + [else + ;; Fall back to iterate of remove + #f])))] [(impersonator? ht) - (loop (impersonator-next ht))] + (if mutable? + (loop (impersonator-next ht)) + (let ([r (loop (impersonator-next ht))]) + (and r + (rewrap-props-impersonator ht r))))] [else - (hash-clear! ht)]))) + (if mutable? + (hash-clear! ht) + (hash-clear ht))]))) (define (impersonate-hash-copy ht) (let* ([val-ht (impersonator-val ht)] diff --git a/racket/src/cs/rumble/impersonator.ss b/racket/src/cs/rumble/impersonator.ss index 542b7f899d..81158d7fcf 100644 --- a/racket/src/cs/rumble/impersonator.ss +++ b/racket/src/cs/rumble/impersonator.ss @@ -309,15 +309,12 @@ (define-record procedure~-struct-chaperone procedure-struct-chaperone ()) (define (impersonate-struct v . args) - (do-impersonate-struct 'impersonate-struct #f v args - make-struct-impersonator make-procedure~-struct-impersonator make-procedure-struct-impersonator)) + (do-impersonate-struct 'impersonate-struct #f v args)) (define (chaperone-struct v . args) - (do-impersonate-struct 'chaperone-struct #t v args - make-struct-chaperone make-procedure-struct-chaperone make-procedure~-struct-chaperone)) + (do-impersonate-struct 'chaperone-struct #t v args)) -(define (do-impersonate-struct who as-chaperone? v args - make-struct-impersonator make-procedure-struct-impersonator make-procedure~-struct-impersonator) +(define (do-impersonate-struct who as-chaperone? v args) (cond [(null? args) v] [else @@ -339,25 +336,26 @@ [iprops orig-iprops]) (let ([get-proc (lambda (what args arity proc->key key-applies?) - (let* ([key-proc (strip-impersonator (car args))] + (let* ([orig-proc (car args)] + [key-proc (strip-impersonator orig-proc)] [key (proc->key key-proc)]) (when (hash-ref saw-props key #f) (raise-arguments-error who "given operation accesses the same value as a previous operation argument" "operation kind" what - "operation procedure" (car args))) + "operation procedure" orig-proc)) (when key-applies? (unless (key-applies? key val) (raise-arguments-error who "operation does not apply to given value" "operation kind" what - "operation procedure" (car args) + "operation procedure" orig-proc "value" v))) (when (null? (cdr args)) (raise-arguments-error who "missing redirection procedure after operation" "operation kind" what - "operation procedure" (car args))) + "operation procedure" orig-proc)) (let ([proc (cadr args)]) (when proc (unless (procedure-arity-includes? proc arity) @@ -367,13 +365,19 @@ "expected" (string-append "(or/c #f (procedure-arity-includes/c " (number->string arity) "))") "operation kind" what - "operation procedure" (car args)))) + "operation procedure" orig-proc))) + (when (and as-chaperone? + (and (impersonator? orig-proc) + (not (chaperone? orig-proc)))) + (raise-arguments-error who + "impersonated operation cannot be used to create a chaperone" + "operation" orig-proc)) (loop #f (cddr args) (if proc (hash-set props key - (if (impersonator? (car args)) - (cons (car args) ; save original accessor, in case it's impersonated + (if (impersonator? orig-proc) + (cons orig-proc ; save original accessor, in case it's impersonated proc) ; the interposition proc proc)) props) @@ -400,14 +404,40 @@ (if as-chaperone? "chaperone" "impersonate") " instance of an authentic structure type") "given value" v)) - (if (and (zero? (hash-count props)) - (eq? iprops orig-iprops)) - v + (cond + [(zero? (hash-count props)) + ;; No structure operations chaperoned, so either unchanged or + ;; a properties-only impersonator + (cond + [(eq? iprops orig-iprops) + v] + [else + ;; Same six cases as below, but for a propery-only impersonator (if (procedure? val) (if (procedure-incomplete-arity? val) - (make-procedure~-struct-impersonator val v iprops props (procedure-arity-mask v)) - (make-procedure-struct-impersonator val v iprops props (procedure-arity-mask v))) - (make-struct-impersonator val v iprops props)))] + (if as-chaperone? + (make-props-procedure~-chaperone val v iprops (procedure-arity-mask v)) + (make-props-procedure~-impersonator val v iprops (procedure-arity-mask v))) + (if as-chaperone? + (make-props-procedure-chaperone val v iprops (procedure-arity-mask v)) + (make-props-procedure-impersonator val v iprops (procedure-arity-mask v)))) + (if as-chaperone? + (make-props-chaperone val v iprops) + (make-props-impersonator val v iprops)))])] + [(procedure? val) + ;; Wrap as a procedure-struct impersonator + (if (procedure-incomplete-arity? val) + (if as-chaperone? + (make-procedure~-struct-chaperone val v iprops props (procedure-arity-mask v)) + (make-procedure~-struct-impersonator val v iprops props (procedure-arity-mask v))) + (if as-chaperone? + (make-procedure-struct-chaperone val v iprops props (procedure-arity-mask v)) + (make-procedure-struct-impersonator val v iprops props (procedure-arity-mask v))))] + [else + ;; Wrap as a plain old struct impersonator + (if as-chaperone? + (make-struct-chaperone val v iprops props) + (make-struct-impersonator val v iprops props))])] [(impersonator-property? (car args)) (loop #f '() diff --git a/racket/src/cs/rumble/intmap.ss b/racket/src/cs/rumble/intmap.ss index 3e39730ea2..9013618bed 100644 --- a/racket/src/cs/rumble/intmap.ss +++ b/racket/src/cs/rumble/intmap.ss @@ -240,7 +240,7 @@ (define-syntax-rule (key=? et k1 k2) (cond [(eq? et 'eq) (eq? k1 k2)] [(eq? et 'eqv) (eqv? k1 k2)] - [else (equal? k1 k2)])) + [else (key-equal? k1 k2)])) (define-syntax-rule (hash-code et k) (cond [(eq? et 'eq) (eq-hash-code k)] diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index cc200585ed..c5b9c44915 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/racket/src/cs/rumble/procedure.ss @@ -192,10 +192,7 @@ [(fixnum? v) (proc-arity-mask (unsafe-struct-ref f v) shift)] [(eq? v 'unsafe) - (proc-arity-mask (if (chaperone? f) - (unsafe-procedure-chaperone-replace-proc f) - (unsafe-procedure-impersonator-replace-proc f)) - shift)] + (proc-arity-mask (impersonator-next f) shift)] [else (proc-arity-mask v (add1 shift))]))]))]))] [(eq? f orig-f) @@ -446,12 +443,12 @@ (lambda (n) (bitwise-arithmetic-shift-right n 1)) " (adding an extra argument)")) (define (do-impersonate-procedure who make-procedure-impersonator proc wrapper - make-props-procedure-impersonator props + make-props-procedure-impersonator props-l arity-shift arity-shift-str) (check who procedure? proc) (let ([m (procedure-arity-mask proc)]) (when wrapper - (check who procedure? wrapper) + (check who procedure? :or-false wrapper) (unless (= m (bitwise-and m (arity-shift (procedure-arity-mask wrapper)))) (raise-arguments-error who (string-append @@ -463,13 +460,15 @@ (impersonator-val proc) proc)] [props (add-impersonator-properties who - props + props-l (if (impersonator? proc) - (impersonator-props proc) + (intmap-remove (impersonator-props proc) impersonator-prop:application-mark) empty-hasheq))]) - (if wrapper - (make-procedure-impersonator val proc props wrapper m) - (make-props-procedure-impersonator val proc props m))))) + (cond + [wrapper (make-procedure-impersonator val proc props wrapper m)] + [(null? props-l) proc] + [else + (make-props-procedure-impersonator val proc props m)])))) (define (procedure-impersonator*? v) (or (procedure*-impersonator? v) @@ -689,7 +688,7 @@ (do-unsafe-impersonate-procedure who make-unsafe-procedure-chaperone proc replace-proc props)) -(define (do-unsafe-impersonate-procedure who make-unsafe-procedure-impersonator proc replace-proc props) +(define (do-unsafe-impersonate-procedure who make-unsafe-procedure-impersonator proc replace-proc props-l) (let ([m (procedure-arity-mask proc)]) (unless (= m (bitwise-and m (procedure-arity-mask replace-proc))) (raise-arguments-error who @@ -700,9 +699,9 @@ (strip-impersonator proc) proc (add-impersonator-properties who - props + props-l (if (impersonator? proc) - (impersonator-props proc) + (intmap-remove (impersonator-props proc) impersonator-prop:application-mark) empty-hasheq)) replace-proc)))