From 962f2472e18356f357f026645bdcebdf3139ba29 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 5 Oct 2012 12:07:00 -0400 Subject: [PATCH] Revamp handling of `Any` as a contract. The contract now has two major differences: - It raises an error when it would have to wrap. - It uses chaperones to delay errors as long as possible In general, using `Any` as a type when exporting to untyped code will now just work, unless the untyped code tries to communicate values back to the typed side, in which case an immediate error will be raised. Much of the implementation comes from the membrane design from [Strickland et al, OOPSLA 2012]. --- .../unit-tests/contract-tests.rkt | 2 +- .../typed-racket/private/type-contract.rkt | 14 ++-- collects/typed-racket/types/printer.rkt | 1 + collects/typed-racket/types/subtype.rkt | 2 +- collects/typed-racket/utils/any-wrap.rkt | 78 +++++++++++++------ 5 files changed, 63 insertions(+), 34 deletions(-) diff --git a/collects/tests/typed-racket/unit-tests/contract-tests.rkt b/collects/tests/typed-racket/unit-tests/contract-tests.rkt index bcf3346594..72ab089863 100644 --- a/collects/tests/typed-racket/unit-tests/contract-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/contract-tests.rkt @@ -20,7 +20,7 @@ (test-suite "Contract Tests" (t (-Number . -> . -Number)) (t (-Promise -Number)) - (t/fail (-set Univ)) + (t (-set Univ)) )) (define-go contract-tests) diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt index c32db15adb..c417b3aa3a 100644 --- a/collects/typed-racket/private/type-contract.rkt +++ b/collects/typed-racket/private/type-contract.rkt @@ -182,11 +182,10 @@ [(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))] ;; any/c doesn't provide protection in positive position [(Univ:) - (if from-typed? - (begin - (set-impersonator!) - #'any-wrap/c) - #'any/c)] + (cond [from-typed? + (set-chaperone!) + #'any-wrap/c] + [else #'any/c])] ;; we special-case lists: [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) (if (and (not from-typed?) (type-equal? elem-ty t:Univ)) @@ -293,7 +292,7 @@ (match-let ([(Mu-name: n-nm _) ty]) (with-syntax ([(n*) (generate-temporaries (list n-nm))]) (parameterize ([vars (cons (list n #'n*) (vars))] - [current-contract-kind flat-sym]) + [current-contract-kind (contract-kind-min kind chaperone-sym)]) (define ctc (t->c b)) #`(letrec ([n* (recursive-contract #,ctc @@ -329,7 +328,8 @@ (with-syntax* ([rec (generate-temporary 'rec)]) (define required-recursive-kind (contract-kind-min kind (if mut? impersonator-sym chaperone-sym))) - (parameterize ((current-contract-kind flat-sym)) + ;(printf "kind: ~a mut-k: ~a req-rec-kind: ~a\n" kind (if mut? impersonator-sym chaperone-sym) required-recursive-kind) + (parameterize ((current-contract-kind (contract-kind-min kind chaperone-sym))) (let ((fld-ctc (t->c fty #:seen (cons (cons ty #'rec) structs-seen) #:kind required-recursive-kind))) #`(let ((rec (recursive-contract struct-ctc #,(contract-kind->keyword (current-contract-kind))))) diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index fdcc44d47b..20df7bdae6 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -213,6 +213,7 @@ [(Name: stx) (fp "~a" (syntax-e stx))] [(app has-name? (? values name)) (fp "~a" name)] + [(StructType: (Struct: nm _ _ _ _ _)) (fp "(StructType ~a)" (syntax-e nm))] [(StructTop: (Struct: nm _ _ _ _ _)) (fp "(Struct ~a)" (syntax-e nm))] [(BoxTop:) (fp "Box")] [(ChannelTop:) (fp "Channel")] diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 281e612389..5abe321655 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -52,7 +52,7 @@ (define k (cons (unsafe-struct-ref s 0) (unsafe-struct-ref t 0))) (define (new-val) (define result (handle-failure (and (subtype* (current-seen) s t) #t))) - (printf "subtype cache miss ~a ~a\n" s t) + ;(printf "subtype cache miss ~a ~a\n" s t) result) (hash-ref! subtype-cache k new-val)) diff --git a/collects/typed-racket/utils/any-wrap.rkt b/collects/typed-racket/utils/any-wrap.rkt index 53921050f4..31ac9ffa07 100644 --- a/collects/typed-racket/utils/any-wrap.rkt +++ b/collects/typed-racket/utils/any-wrap.rkt @@ -2,44 +2,72 @@ (require racket/match racket/contract/base racket/contract/combinator) -(define-struct any-wrap (val) - #:property prop:custom-write - (lambda (v p write?) - (fprintf p "#" (any-wrap-val v)))) - (define undef (letrec ([x x]) x)) -(define (traverse wrap?) +(define (traverse b) + (define (fail v) + (raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any`")) + (define (t v) + (define (wrap-struct s) + (define (extract-functions struct-type) + (define-values (sym init auto ref set! imms par skip?) + (struct-type-info type)) + (when skip? (fail s)) ;; "Opaque struct type!") + (define-values (fun/chap-list _) + (for/fold ([res null] + [imms imms]) + ([n (in-range (+ init auto))]) + (if (and (pair? imms) (= (car imms) n)) + ;; field is immutable + (values + (list* (make-struct-field-accessor ref n) + (lambda (s v) (t v)) + res) + (cdr imms)) + ;; field is mutable + (values + (list* (make-struct-field-accessor ref n) + (lambda (s v) (t v)) + (make-struct-field-mutator set! n) + (lambda (s v) (fail s)) + res) + imms)))) + (cond + [par (cons fun/chap-list (extract-functions par))] + [else fun/chap-list])) + (define-values (type skipped?) (struct-info s)) + (when skipped? (fail s)); "Opaque struct type!" + (apply chaperone-struct s (extract-functions type))) + (match v - [(? (lambda (e) (and (any-wrap? e) (not wrap?)))) (any-wrap-val v)] [(? (lambda (e) (or (number? e) (string? e) (char? e) (symbol? e) (null? e) (regexp? e) (eq? undef e) (keyword? e) (bytes? e) (boolean? e) (void? e)))) v] [(cons x y) (cons (t x) (t y))] - [(and (? immutable?) (? vector?)) - (for/vector #:length (vector-length v) - ([i (in-vector v)]) (t i))] - [(and (? immutable?) (box v)) (box (t v))] - [(and (? immutable?) (? hash? v)) - ((cond [(hash-eq? v) make-immutable-hasheq] - [(hash-eqv? v) make-immutable-hasheqv] - [else make-immutable-hash]) - (for/list ([(k v) (in-hash v)]) - (cons (t k) (t v))))] - #; ;; need to check immutablity - [(? prefab-struct-key) - (let* ([k (prefab-struct-key v)] - [vals (struct->vector v)]) - (apply make-prefab-struct k (for/list ([i (in-vector vals 1)]) i)))] - [_ (if wrap? (make-any-wrap v) v)])) + [(? vector?) (chaperone-vector v + (lambda (v i e) (t e)) + (lambda (v i e) (fail v)))] + [(? box?) (chaperone-box v + (lambda (v e) (t e)) + (lambda (v e) (fail v)))] + [(? hash?) (chaperone-hash v + (lambda (h k) (values k (lambda (h k v) (t v)))) ;; ref + (lambda (h k n) (if (immutable? v) (values k n) (fail v))) ;; set + (lambda (h v) v) ;; remove + (lambda (h k) (t k)))] ;; key + [(? evt?) (chaperone-evt v (lambda (e) (values e t)))] + [(? struct?) (wrap-struct v)] + [(? procedure?) (chaperone-procedure v (lambda _ (fail v)))] + [_ (fail v)])) t) (define any-wrap/c - (make-contract + (make-chaperone-contract #:name 'Any - #:projection (compose traverse blame-original?))) + #:first-order (lambda (x) #t) + #:projection traverse)) (provide any-wrap/c)