diff --git a/racket/collects/racket/private/class-wrapped.rkt b/racket/collects/racket/private/class-wrapped.rkt index 03364d3d34..5962bcea7a 100644 --- a/racket/collects/racket/private/class-wrapped.rkt +++ b/racket/collects/racket/private/class-wrapped.rkt @@ -20,6 +20,7 @@ (struct wrapped-object (object neg-extra-arg-vec pos-field-projs neg-field-projs neg-party) #:transparent + #:authentic #:property prop:custom-write (λ (stct port mode) (do-custom-write (wrapped-object-object stct) port mode))) diff --git a/racket/src/schemify/find-definition.rkt b/racket/src/schemify/find-definition.rkt index 3fb7237aae..4ad086090b 100644 --- a/racket/src/schemify/find-definition.rkt +++ b/racket/src/schemify/find-definition.rkt @@ -47,7 +47,7 @@ a-known-constant))] [knowns (hash-set knowns (unwrap s?) - (known-predicate 2 type))] + (known-struct-predicate 2 type struct:s (struct-type-info-authentic? info)))] [knowns (let* ([immediate-count (struct-type-info-immediate-field-count info)] [parent-count (- (struct-type-info-field-count info) @@ -87,7 +87,7 @@ a-known-constant))] [knowns (hash-set knowns (unwrap s?) - (known-predicate 2 type))]) + (known-struct-predicate 2 type struct:s (struct-type-info-authentic? info)))]) ;; For now, we don't try to track the position-consuming accessor or mutator (hash-set knowns (unwrap struct:s) (known-struct-type type (struct-type-info-field-count info) diff --git a/racket/src/schemify/inline.rkt b/racket/src/schemify/inline.rkt index de193abe7f..e733f70fe8 100644 --- a/racket/src/schemify/inline.rkt +++ b/racket/src/schemify/inline.rkt @@ -88,6 +88,8 @@ (define (inline-type-id k im add-import! mutated imports) (define type-id (cond + [(known-struct-predicate? k) + (known-struct-predicate-type-id k)] [(known-field-accessor? k) (known-field-accessor-type-id k)] [(known-field-mutator? k) @@ -99,6 +101,10 @@ (cond [(not type-id) #f] [(not im) '()] + [(known-struct-predicate/need-imports? k) + (needed->env (known-struct-predicate/need-imports-needed k) + add-import! + im)] [(known-field-accessor/need-imports? k) (needed->env (known-field-accessor/need-imports-needed k) add-import! @@ -233,6 +239,18 @@ (known-procedure-arity-mask k) (if serializable? (wrap-truncate-paths expr) expr) (needed->list needed))])] + [(known-struct-predicate? k) + (define needed (needed-imports (known-struct-predicate-type-id k) prim-knowns imports exports '() '#hasheq())) + (cond + [needed + (known-struct-predicate/need-imports (known-procedure-arity-mask k) + (known-predicate-type k) + (known-struct-predicate-type-id k) + (known-struct-predicate-authentic? k) + (needed->list needed))] + [else + (known-predicate (known-procedure-arity-mask k) + (known-predicate-type k))])] [(known-field-accessor? k) (define needed (needed-imports (known-field-accessor-type-id k) prim-knowns imports exports '() '#hasheq())) (cond diff --git a/racket/src/schemify/known.rkt b/racket/src/schemify/known.rkt index 5021856b74..669b53dc86 100644 --- a/racket/src/schemify/known.rkt +++ b/racket/src/schemify/known.rkt @@ -30,8 +30,10 @@ known-predicate known-predicate? known-predicate-type known-accessor known-accessor? known-accessor-type known-mutator known-mutator? known-mutator-type + known-struct-predicate known-struct-predicate? known-struct-predicate-type-id known-struct-predicate-authentic? known-field-accessor known-field-accessor? known-field-accessor-type-id known-field-accessor-pos known-field-mutator known-field-mutator? known-field-mutator-type-id known-field-mutator-pos + known-struct-predicate/need-imports known-struct-predicate/need-imports? known-struct-predicate/need-imports-needed known-field-accessor/need-imports known-field-accessor/need-imports? known-field-accessor/need-imports-needed known-field-mutator/need-imports known-field-mutator/need-imports? known-field-mutator/need-imports-needed known-struct-type-property/immediate-guard known-struct-type-property/immediate-guard? @@ -100,8 +102,10 @@ (struct known-predicate (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure) (struct known-accessor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) (struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) +(struct known-struct-predicate (type-id authentic?) #:prefab #:omit-define-syntaxes #:super struct:known-predicate) (struct known-field-accessor (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-accessor) (struct known-field-mutator (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-mutator) +(struct known-struct-predicate/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-predicate) (struct known-field-accessor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-field-accessor) (struct known-field-mutator/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-field-mutator) diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index 908b7215b7..8825c4fb61 100644 --- a/racket/src/schemify/schemify.rkt +++ b/racket/src/schemify/schemify.rkt @@ -797,6 +797,21 @@ body `(let ([,tmp ,e]) ,body))) + (define (inline-struct-predicate k s-rator im args) + ;; For imported predicates on authentic structure types, it's worth + ;; inlining the predicate to enable cptypes optimizations. + (define type-id (and im + (known-struct-predicate-authentic? k) + (pair? args) + (null? (cdr args)) + (inline-type-id k im add-import! mutated imports))) + (cond + [type-id + (define tmp (maybe-tmp (car args) 'v)) + (define ques `(unsafe-struct? ,tmp ,(schemify type-id 'fresh))) + (wrap-tmp tmp (car args) + ques)] + [else #f])) (define (inline-field-access k s-rator im args) ;; For imported accessors or for JIT mode, inline the ;; selector with an `unsafe-struct?` test plus `unsafe-struct*-ref`. @@ -845,6 +860,10 @@ (cdr e) #t for-cify? prim-knowns knowns imports mutated simples))] + [(and (not for-cify?) + (known-struct-predicate? k) + (inline-struct-predicate k s-rator im args)) + => (lambda (e) e)] [(and (not for-cify?) (known-field-accessor? k) (inline-field-access k s-rator im args))