syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

preserve sharing in serializer

This commit is contained in:
Michael Ballantyne 2020-09-28 19:22:32 -06:00 committed by Sam Caldwell
parent db3fc2acd9
commit c988c4f462
1 changed files with 66 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
racket/typed/syntax-serializer.rkt
View File

@ -13,8 +13,20 @@
;(require racket/pretty) ;(require racket/pretty)
(define (serialize-syntax stx) (define (serialize-syntax stx)
(displayln 'serialize)
;(print-syntax-width +inf.0)
;(println stx)
;(pretty-print (syntax->datum stx))
(define unique-tag (gensym)) (define unique-tag (gensym))
(define table (hasheq)) (define table (hasheq))
(define dedup-table (hasheq))
(define (dedup k f)
(if (hash-has-key? dedup-table k)
(hash-ref dedup-table k)
(let ([res (f)])
(set! dedup-table (hash-set dedup-table k res))
res)))
(define (lift! el) (define (lift! el)
(define tag-sym (gensym)) (define tag-sym (gensym))
@ -34,22 +46,35 @@
(cons k serialized-val)))) (cons k serialized-val))))
(define (serialize-element! el #:always-lift? [always-lift? #f]) (define (serialize-element! el #:always-lift? [always-lift? #f])
(syntax-map (dedup
el el
(lambda (tail? d) d) (lambda ()
(lambda (orig-s d) (syntax-map
(if (or always-lift? el
(ormap (lambda (p) (syntax-property-preserved? orig-s p)) (lambda (tail? d) d)
(syntax-property-symbol-keys orig-s))) (lambda (orig-s d)
(lift! (build-props! orig-s d)) ;(when (and always-lift? (not (ref? (hash-ref dedup-table orig-s)))) ; TODO
(datum->syntax orig-s d orig-s #f))) ;(error 'dedup "lift error"))
syntax-e)) (dedup
orig-s
(lambda ()
(if (or always-lift?
(ormap (lambda (p) (syntax-property-preserved? orig-s p))
(syntax-property-symbol-keys orig-s)))
(lift! (build-props! orig-s d))
(datum->syntax orig-s d orig-s #f)))))
syntax-e))))
(define top-s (serialize-element! stx)) (define top-s (serialize-element! stx))
(datum->syntax #f (serialized-syntax unique-tag table top-s))) (define res (datum->syntax #f (serialized-syntax unique-tag table top-s)))
;(displayln 'serialize-out)
;(println res)
;(pretty-print (syntax->datum res))
res)
(define (deserialize-syntax ser) (define (deserialize-syntax ser)
;(displayln 'deserialize-in) (displayln 'deserialize)
;(print-syntax-width +inf.0) ;(print-syntax-width +inf.0)
;(println ser) ;(println ser)
;(pretty-print (syntax->datum ser)) ;(pretty-print (syntax->datum ser))
@ -57,10 +82,18 @@
[(serialized-syntax unique-tag-stx table-stx contents) [(serialized-syntax unique-tag-stx table-stx contents)
(define unique-tag (syntax-e unique-tag-stx)) (define unique-tag (syntax-e unique-tag-stx))
(define table (syntax-e table-stx)) (define table (syntax-e table-stx))
(define dedup-table (hasheq))
(define (dedup k f)
(if (hash-has-key? dedup-table k)
(hash-ref dedup-table k)
(let ([res (f)])
(set! dedup-table (hash-set dedup-table k res))
res)))
(define (maybe-syntax-e v) (define (maybe-syntax-e v)
(if (syntax? v) (syntax-e v) v)) (if (syntax? v) (syntax-e v) v))
(define (deserialize-stx-with-props ref-sym) (define (deserialize-stx-with-props ref-sym)
(match-define (stx-with-props stx ps) (syntax-e (hash-ref table ref-sym))) (match-define (stx-with-props stx ps) (syntax-e (hash-ref table ref-sym)))
(define deserialized-nested-stx (deserialize-element stx)) (define deserialized-nested-stx (deserialize-element stx))
@ -76,18 +109,26 @@
[(datum-val v) [(datum-val v)
(deserialize-element (syntax->datum v))])) (deserialize-element (syntax->datum v))]))
(syntax-property stx k prop-val #t))) (syntax-property stx k prop-val #t)))
(define (deserialize-element el) (define (deserialize-element el)
(syntax-map (dedup
el el
(lambda (tail? d) (lambda ()
(match d (syntax-map
[(ref tag sym) el
#:when (equal? (maybe-syntax-e tag) unique-tag) (lambda (tail? d)
(deserialize-stx-with-props (maybe-syntax-e sym))] (match d
[_ d])) [(ref tag sym)
(lambda (orig-s d) (datum->syntax orig-s d orig-s #f)) #:when (equal? (maybe-syntax-e tag) unique-tag)
syntax-e)) (dedup
sym
(lambda () (deserialize-stx-with-props (maybe-syntax-e sym))))]
[_ d]))
(lambda (orig-s d)
(dedup
orig-s
(lambda () (datum->syntax orig-s d orig-s #f))))
syntax-e))))
(define res (deserialize-element contents)) (define res (deserialize-element contents))
;(displayln 'deserialize-out) ;(displayln 'deserialize-out)