From 122ef0b5f9f092a954c8e3244615d3145f962f9b Mon Sep 17 00:00:00 2001 From: Sam Caldwell Date: Thu, 24 Sep 2020 13:18:55 -0400 Subject: [PATCH] try out the syntax serializer --- racket/typed/core-types.rkt | 36 ++--- racket/typed/syntax-serializer.rkt | 247 +++++++++++++++++++++++++++++ 2 files changed, 263 insertions(+), 20 deletions(-) create mode 100644 racket/typed/syntax-serializer.rkt diff --git a/racket/typed/core-types.rkt b/racket/typed/core-types.rkt index caf7cc3..0156cca 100644 --- a/racket/typed/core-types.rkt +++ b/racket/typed/core-types.rkt @@ -35,6 +35,7 @@ (require (postfix-in - racket/set)) (require (postfix-in - racket/match)) (require (postfix-in - (only-in racket/format ~a))) +(require (for-syntax "syntax-serializer.rkt")) (module+ test @@ -431,9 +432,10 @@ (define-syntax define-type-alias (syntax-parser [(_ alias:id τ:type) - #:with kind (detach #'τ.norm ':) + ;; #:with kind (detach #'τ.norm ':) + #:with serialized-τ (serialize-syntax #'τ.norm) #'(define-syntax- alias - (make-variable-like-transformer (attach #'τ ': #'kind)))] + (make-variable-like-transformer (deserialize-syntax #'serialized-τ)))] [(_ (f:id x:id ...) ty) #'(define-syntax- (f stx) (syntax-parse stx @@ -773,24 +775,14 @@ #:datum-literals (:) [(_ lib [name:id : ty:type] ...) #:with (name- ...) (format-ids "~a-" #'(name ...)) - #:with (kind ...) (for/list ([t (in-syntax #'(ty.norm ...))]) - (detach t ':)) - (define nm1 (syntax-e (first (syntax->list #'(name ...))))) - (define kind1 (first (syntax->list #'(kind ...)))) - (when (equal? nm1 'identity) - (printf "require/typed: ~a\n" nm1) - (syntax-parse kind1 - [(~Base t) - (define t-i (syntax-local-introduce #'t)) - (pretty-print (syntax-debug-info t-i)) - (pretty-print (identifier-binding t-i))])) + #:with (serialized-ty ...) (for/list ([t (in-syntax #'(ty.norm ...))]) + (serialize-syntax t)) (syntax/loc stx (begin- (require (only-in lib [name name-] ...)) (define-syntax name (make-variable-like-transformer - (add-orig (assign-type #'name- - (attach #'ty ': ((current-type-eval) #'Type)) + (add-orig (assign-type #'name- (deserialize-syntax #'serialized-ty) #:wrap? #f) #'name))) ...))])) @@ -1406,12 +1398,12 @@ (define-for-syntax (int-def-ctx-bind-type-rename x x- t ctx) (when DEBUG-BINDINGS? (printf "adding to context ~a\n" (syntax-debug-info x))) - (define kind (detach t KIND-TAG)) + (define serialized-ty (serialize-syntax t)) (syntax-local-bind-syntaxes (list x-) #f ctx) (syntax-local-bind-syntaxes (list x) #`(make-rename-transformer (add-orig - (attach #'#,x- ': (attach #'#,t '#,KIND-TAG #'#,kind)) + (attach #'#,x- ': (deserialize-syntax #'#,serialized-ty)) #'#,x) #;(add-orig (assign-type #'#,x- #'#,t #:wrap? #f) #'#,x)) ctx)) @@ -1499,10 +1491,10 @@ [(_ x:id x-:id τ e) ;; including a syntax binding for x allows for module-top-level references ;; (where walk/bind won't replace further uses) and subsequent provides - #:with kind (detach #'τ ':) + #:with serialized-τ (serialize-syntax #'τ) #'(begin- (define-syntax x - (make-variable-like-transformer (add-orig (attach #'x- ': (attach #'τ ': #'kind)) #'x))) + (make-variable-like-transformer (add-orig (attach #'x- ': (deserialize-syntax #'serialized-τ)) #'x))) (define- x- e))])) ;; copied from ext-stlc @@ -1628,6 +1620,7 @@ [⊢ e_fn ≫ e_fn- ⇒ (~∀+ Xs (~→fn tyX_in ... tyX_out))] ;; successfully matched a polymorphic fn type, don't backtrack #:cut + #:do [(printf "A\n")] #:with tyX_args #'(tyX_in ... tyX_out) ;; solve for type variables Xs #:with [[e_arg- ...] Xs* cs] (solve #'Xs #'tyX_args this-syntax) @@ -1638,6 +1631,7 @@ (instantiable? x ty)) "type variables must be flat and finite" ;; instantiate polymorphic function type + #:do [(printf "B\n")] #:with [τ_in ... τ_out] (ttc:inst-types/cs #'Xs* #'cs #'tyX_args) #:with (unsolved-X ...) (find-free-Xs #'Xs* #'τ_out) ;; arity check @@ -1649,6 +1643,7 @@ #:with (τ_arg ...) (stx-map typeof #'(e_arg- ...)) ;; typecheck args [τ_arg τ⊑ τ_in #:for e_arg] ... + #:do [(printf "C\n")] #:with τ_out* (if (stx-null? #'(unsolved-X ...)) #'τ_out (syntax-parse #'τ_out @@ -1661,7 +1656,8 @@ #f (mk-app-poly-infer-error this-syntax #'(τ_in ...) #'(τ_arg ...) #'e_fn) this-syntax))) - ((type-eval) #'(∀+ (unsolved-X ... Y ...) τ_out))])) + (type-eval #'(∀+ (unsolved-X ... Y ...) τ_out))])) + #:do [(printf "D\n")] -------- [⊢ (#%plain-app- e_fn- e_arg- ...) ⇒ τ_out*]] ;; All Other Functions diff --git a/racket/typed/syntax-serializer.rkt b/racket/typed/syntax-serializer.rkt new file mode 100644 index 0000000..3d91392 --- /dev/null +++ b/racket/typed/syntax-serializer.rkt @@ -0,0 +1,247 @@ +#lang racket/base + +(provide serialize-syntax deserialize-syntax) + +(require racket/dict racket/match) + +(struct serialized-syntax (unique-tag table contents) #:prefab) +(struct stx-with-props (stx ps) #:prefab) +(struct syntax-val (stx) #:prefab) +(struct datum-val (d) #:prefab) +(struct ref (unique-tag sym) #:prefab) + +(define (serialize-syntax stx) + (define unique-tag (gensym)) + (define table (hasheq)) + + (define (lift! el) + (define tag-sym (gensym)) + (set! table (hash-set table tag-sym el)) + (ref unique-tag tag-sym)) + + (define (build-props! orig-s d) + (stx-with-props + (datum->syntax orig-s d orig-s #f) + (for/list ([k (syntax-property-symbol-keys orig-s)] + #:when (syntax-property-preserved? orig-s k)) + (define val (syntax-property orig-s k)) + (define serialized-val + (if (syntax? val) + (syntax-val (serialize-element! val)) + (datum-val (serialize-element! val)))) + (cons k serialized-val)))) + + (define (serialize-element! el) + (syntax-map + el + (lambda (tail? d) d) + (lambda (orig-s d) + (if (not (ormap (lambda (p) (syntax-property-preserved? orig-s p)) + (syntax-property-symbol-keys orig-s))) + (datum->syntax orig-s d orig-s #f) + (lift! (build-props! orig-s d)))) + syntax-e)) + + (define top-s (serialize-element! stx)) + (datum->syntax #f (serialized-syntax unique-tag table top-s))) + +(define (deserialize-syntax ser) + (match (syntax-e ser) + [(serialized-syntax unique-tag-stx table-stx contents) + (define unique-tag (syntax-e unique-tag-stx)) + (define table (syntax-e table-stx)) + + (define (maybe-syntax-e v) + (if (syntax? v) (syntax-e v) v)) + + (define (deserialize-stx-with-props ref-sym) + (match-define (stx-with-props stx ps) (syntax-e (hash-ref table ref-sym))) + (for/fold ([stx stx]) + ([stx-pr (syntax->list ps)]) + (define pr (syntax-e stx-pr)) + (define k (syntax-e (car pr))) + (define v (syntax-e (cdr pr))) + (define prop-val + (match v + [(syntax-val v) + (deserialize-element v)] + [(datum-val v) + (deserialize-element (syntax->datum v))])) + (syntax-property stx k prop-val #t))) + + (define (deserialize-element el) + (syntax-map + el + (lambda (tail? d) + (match d + [(ref tag sym) + #:when (equal? (maybe-syntax-e tag) unique-tag) + (deserialize-stx-with-props (maybe-syntax-e sym))] + [_ d])) + (lambda (orig-s d) (datum->syntax orig-s d orig-s #f)) + syntax-e)) + + (deserialize-element contents)])) + +(module+ test + (require rackunit) + + (define orig #`(1 #,(syntax-property #'2 ': (syntax-property #'Int ':: #'Type #t) #t))) + (define s (serialize-syntax orig)) + (define d (deserialize-syntax s)) + + (check-true + (bound-identifier=? + (syntax-property (syntax-property (cadr (syntax-e d)) ':) '::) + #'Type)) + + (check-true + (bound-identifier=? + (syntax-property (cadr (syntax-e d)) ':) + #'Int)) + + (check-equal? + (syntax-position orig) + (syntax-position d)) + + (check-equal? + (syntax-position (syntax-property (cadr (syntax-e orig)) ':)) + (syntax-position (syntax-property (cadr (syntax-e d)) ':))) + + (check-equal? + (syntax-position (car (syntax-e orig))) + (syntax-position (car (syntax-e d))))) + + +;; ---------------------------------------------------------------- + +;; syntax-map and datum-map copied from the expander files +;; syntax/datum-map.rkt +;; syntax/syntax.rkt + +(require racket/fixnum racket/prefab) + +;; `(datum-map v f)` walks over `v`, traversing objects that +;; `datum->syntax` traverses to convert content to syntax objects. +;; +;; `(f tail? d)` is called on each datum `d`, where `tail?` +;; indicates that the value is a pair/null in a `cdr` --- so that it +;; doesn't need to be wrapped for `datum->syntax`, for example; +;; the `tail?` argument is actually #f or a fixnum for a lower bound +;; on `cdr`s that have been taken +;; +;; `gf` is like `f`, but `gf` is used when the argument might be +;; syntax; if `gf` is provided, `f` can assume that its argument +;; is not syntax +;; +;; If a `seen` argument is provided, then it should be an `eq?`-based +;; hash table, and cycle checking is enabled; when a cycle is +;; discovered, the procedure attached to 'cycle-fail in the initial +;; table is called +;; +;; If a `known-pairs` argument is provided, then it should be an +;; `eq?`-based hash table to map pairs that can be returned as-is +;; in a `tail?` position + +;; The inline version uses `f` only in an application position to +;; help avoid allocating a closure. It also covers only the most common +;; cases, defering to the general (not inlined) function for other cases. +(define (datum-map s f [gf f] [seen #f] [known-pairs #f]) + (let loop ([tail? #f] [s s] [prev-depth 0]) + (define depth (fx+ 1 prev-depth)) ; avoid cycle-checking overhead for shallow cases + (cond + [(and seen (depth . fx> . 32)) + (datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen known-pairs)] + [(null? s) (f tail? s)] + [(pair? s) + (f tail? (cons (loop #f (car s) depth) + (loop 1 (cdr s) depth)))] + [(symbol? s) (f #f s)] + [(boolean? s) (f #f s)] + [(number? s) (f #f s)] + [(or (vector? s) (box? s) (prefab-struct-key s) (hash? s)) + (datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen known-pairs)] + [else (gf #f s)]))) + +(define (datum-map-slow tail? s f seen known-pairs) + (let loop ([tail? tail?] [s s] [prev-seen seen]) + (define seen + (cond + [(and prev-seen (datum-has-elements? s)) + (cond + [(hash-ref prev-seen s #f) + ((hash-ref prev-seen 'cycle-fail) s)] + [else (hash-set prev-seen s #t)])] + [else prev-seen])) + (cond + [(null? s) (f tail? s)] + [(pair? s) + (cond + [(and known-pairs + tail? + (hash-ref known-pairs s #f)) + s] + [else + (f tail? (cons (loop #f (car s) seen) + (loop (if tail? (fx+ 1 tail?) 1) (cdr s) seen)))])] + [(or (symbol? s) (boolean? s) (number? s)) + (f #f s)] + [(vector? s) + (f #f (vector->immutable-vector + (for/vector #:length (vector-length s) ([e (in-vector s)]) + (loop #f e seen))))] + [(box? s) + (f #f (box-immutable (loop #f (unbox s) seen)))] + [(immutable-prefab-struct-key s) + => (lambda (key) + (f #f + (apply make-prefab-struct + key + (for/list ([e (in-vector (struct->vector s) 1)]) + (loop #f e seen)))))] + [(and (hash? s) (immutable? s)) + (cond + [(hash-eq? s) + (f #f + (for/hasheq ([(k v) (in-hash s)]) + (values k (loop #f v seen))))] + [(hash-eqv? s) + (f #f + (for/hasheqv ([(k v) (in-hash s)]) + (values k (loop #f v seen))))] + [else + (f #f + (for/hash ([(k v) (in-hash s)]) + (values k (loop #f v seen))))])] + [else (f #f s)]))) + +(define (datum-has-elements? d) + (or (pair? d) + (vector? d) + (box? d) + (immutable-prefab-struct-key d) + (and (hash? d) (immutable? d) (positive? (hash-count d))))) + +;; `(syntax-map s f d->s)` walks over `s`: +;; +;; * `(f tail? d)` is called to each datum `d`, where `tail?` +;; indicates that the value is a pair/null in a `cdr` --- so that it +;; doesn't need to be wrapped for `datum->syntax`, for example +;; +;; * `(d->s orig-s d)` is called for each syntax object, +;; and the second argument is result of traversing its datum +;; +;; * the `s-e` function extracts content of a syntax object +;; +;; The optional `seen` argument is an `eq?`-based immutable hash table +;; to detect and reject cycles. See `datum-map`. + +(define (syntax-map s f d->s s-e [seen #f]) + (let loop ([s s]) + (datum-map s + f + (lambda (tail? v) + (cond + [(syntax? v) (d->s v (loop (s-e v)))] + [else (f tail? v)])) + seen)))