suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

expander: avoid VM-specific expansion

Browse Source 
Move different handling of serialized syntax data to the schemify
layer instead of te expander, so that the result of compiling in
machine-independent form is the same for traditional Racket and Racket
CS.
This commit is contained in:
Matthew Flatt 2019-03-12 06:00:36 -06:00
parent d0d391d76b
commit 6e958b627f
8 changed files with 176 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
pkgs/compiler-lib/compiler/decompile.rkt
View File

@ -269,12 +269,14 @@
(define-values ,_
(lambda ,_
(begin
(vector-copy! ,_ ,_ (let-values (((.inspector) #f))
(deserialize .mpi-vector .inspector .bulk-binding-registry
',num-mutables ',mutable-vec
',num-shares ',share-vec
',mutable-fill-vec
',result-vec)))
(vector-copy! ,_ ,_ (let-values ([(.inspector) #f])
(let-values ([(data)
'#(,mutable-vec ,share-vec ,mutable-fill-vec ,result-vec)])
(deserialize .mpi-vector .inspector .bulk-binding-registry
',num-mutables (,_ data 0)
',num-shares (,_ data 1)
(,_ data 2)
(,_ data 3)))))
,_))))
(decompile-deserialize '.mpi-vector '.inspector '.bulk-binding-registry
num-mutables mutable-vec
@ -282,7 +284,6 @@
mutable-fill-vec
result-vec)]
[else
(log-error ">> HERE ~.s" (strip-correlated expr))
(decompile-linklet l)])]
[else
(decompile-linklet l)]))

3
racket/src/expander/compile/correlate.rkt
View File

@ -15,7 +15,8 @@
->correlated
correlate-source-name
compile-keep-source-locations!)
compile-keep-source-locations!
keep-source-locations?)
(define keep-source-locations? #f)

32
racket/src/expander/compile/serialize.rkt
View File

@ -624,27 +624,17 @@
,mutable-fills-expr
,result-expr))
(cond
[(eq? 'chez-scheme (system-type 'vm))
;; It's better to interpret the quoted-data construction in Chez Scheme,
;; instead of compiling the construction, because it's more compact
;; and easier to delay. Rely on `fasl->s-exp/intern` as a primitive
;; (from the linklet perspective) that is installed on startup.
`(let-values ([(data) (fasl->s-exp/intern
,(s-exp->fasl
(vector mutable-shell-bindings
shared-bindings
mutable-fills
result)))])
,(finish '(unsafe-vector-ref data 0)
'(unsafe-vector-ref data 1)
'(unsafe-vector-ref data 2)
'(unsafe-vector-ref data 3)))]
[else
(finish `',mutable-shell-bindings
`',shared-bindings
`',mutable-fills
`',result)]))
;; Putting the quoted-data construction into one vector makes
;; it easy to specialize in some back ends to a more compact
;; format.
`(let-values ([(data) ',(vector mutable-shell-bindings
shared-bindings
mutable-fills
result)])
,(finish '(unsafe-vector*-ref data 0)
'(unsafe-vector*-ref data 1)
'(unsafe-vector*-ref data 2)
'(unsafe-vector*-ref data 3))))
(define (sorted-hash-keys ht)
(define ks (hash-keys ht))

5
racket/src/expander/expand/expr.rkt
View File

@ -25,7 +25,8 @@
"reference-record.rkt"
"prepare.rkt"
"log.rkt"
"parsed.rkt")
"parsed.rkt"
"../compile/correlate.rkt")
;; ----------------------------------------
@ -414,7 +415,7 @@
(list (core-id 'quote phase)
null)))]
[else
(define keep-for-parsed? (eq? (system-type 'vm) 'chez-scheme))
(define keep-for-parsed? keep-source-locations?)
(define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? keep-for-parsed?))
(define prefixless (cdr (syntax-e disarmed-s)))
(define rebuild-prefixless (and (syntax? prefixless)

72
racket/src/racket/src/startup.inc
View File

@ -22073,35 +22073,25 @@ static const char *startup_source =
" shared-bindings-expr_0"
" mutable-fills-expr_0"
" result-expr_0)))))"
"(if(eq? 'chez-scheme(system-type 'vm))"
"(let-values()"
"(list"
" 'let-values"
"(list"
"(list"
" '(data)"
"(list"
" 'fasl->s-exp/intern"
"(let-values(((temp20_0)"
" 'quote"
"(vector"
" mutable-shell-bindings_0"
" shared-bindings_0"
" mutable-fills_0"
" result_0)))"
"(s-exp->fasl11.1 #f temp20_0 #f)))))"
" result_0))))"
"(finish_0"
" '(unsafe-vector-ref data 0)"
" '(unsafe-vector-ref data 1)"
" '(unsafe-vector-ref data 2)"
" '(unsafe-vector-ref data 3))))"
"(let-values()"
"(finish_0"
"(list 'quote mutable-shell-bindings_0)"
"(list 'quote shared-bindings_0)"
"(list 'quote mutable-fills_0)"
"(list"
" 'quote"
" result_0))))))))))))))))))))))))))))))))))))))"
" '(unsafe-vector*-ref data 0)"
" '(unsafe-vector*-ref data 1)"
" '(unsafe-vector*-ref data 2)"
" '(unsafe-vector*-ref"
" data"
" 3)))))))))))))))))))))))))))))))))))))"
"(define-values"
"(sorted-hash-keys)"
"(lambda(ht_0)"
@ -22113,16 +22103,16 @@ static const char *startup_source =
"(let-values() ks_0)"
"(if(andmap2 symbol? ks_0)"
"(let-values()"
"(let-values(((ks21_0) ks_0)((symbol<?22_0) symbol<?))(sort7.1 #f #f ks21_0 symbol<?22_0)))"
"(let-values(((ks20_0) ks_0)((symbol<?21_0) symbol<?))(sort7.1 #f #f ks20_0 symbol<?21_0)))"
"(if(andmap2 scope? ks_0)"
"(let-values()"
"(let-values(((ks23_0) ks_0)((scope<?24_0) scope<?))(sort7.1 #f #f ks23_0 scope<?24_0)))"
"(let-values(((ks22_0) ks_0)((scope<?23_0) scope<?))(sort7.1 #f #f ks22_0 scope<?23_0)))"
"(if(andmap2 shifted-multi-scope? ks_0)"
"(let-values()"
"(let-values(((ks25_0) ks_0)((shifted-multi-scope<?26_0) shifted-multi-scope<?))"
"(sort7.1 #f #f ks25_0 shifted-multi-scope<?26_0)))"
"(let-values(((ks24_0) ks_0)((shifted-multi-scope<?25_0) shifted-multi-scope<?))"
"(sort7.1 #f #f ks24_0 shifted-multi-scope<?25_0)))"
"(if(andmap2 real? ks_0)"
"(let-values()(let-values(((ks27_0) ks_0)((<28_0) <))(sort7.1 #f #f ks27_0 <28_0)))"
"(let-values()(let-values(((ks26_0) ks_0)((<27_0) <))(sort7.1 #f #f ks26_0 <27_0)))"
"(let-values() ks_0)))))))))))"
"(define-values"
"(deserialize)"
@ -23279,29 +23269,29 @@ static const char *startup_source =
"(define-values"
"(syntax-module-path-index-shift/no-keywords)"
"(let-values(((syntax-module-path-index-shift_0)"
"(let-values(((core33_0)"
"(lambda(s30_0 from-mpi31_0 to-mpi32_0 inspector29_0)"
"(let-values(((core32_0)"
"(lambda(s29_0 from-mpi30_0 to-mpi31_0 inspector28_0)"
"(begin"
" 'core33"
"(let-values(((s_0) s30_0))"
"(let-values(((from-mpi_0) from-mpi31_0))"
"(let-values(((to-mpi_0) to-mpi32_0))"
"(let-values(((inspector_0) inspector29_0))"
" 'core32"
"(let-values(((s_0) s29_0))"
"(let-values(((from-mpi_0) from-mpi30_0))"
"(let-values(((to-mpi_0) to-mpi31_0))"
"(let-values(((inspector_0) inspector28_0))"
"(let-values()"
"(let-values(((s35_0) s_0)"
"((from-mpi36_0) from-mpi_0)"
"((to-mpi37_0) to-mpi_0)"
"((inspector38_0) inspector_0))"
"(let-values(((s34_0) s_0)"
"((from-mpi35_0) from-mpi_0)"
"((to-mpi36_0) to-mpi_0)"
"((inspector37_0) inspector_0))"
"(syntax-module-path-index-shift13.1"
" #f"
" s35_0"
" from-mpi36_0"
" to-mpi37_0"
" inspector38_0)))))))))))"
" s34_0"
" from-mpi35_0"
" to-mpi36_0"
" inspector37_0)))))))))))"
"(case-lambda"
"((s_0 from-mpi_0 to-mpi_0)"
"(begin 'syntax-module-path-index-shift(core33_0 s_0 from-mpi_0 to-mpi_0 #f)))"
"((s_0 from-mpi_0 to-mpi_0 inspector29_0)(core33_0 s_0 from-mpi_0 to-mpi_0 inspector29_0))))))"
"(begin 'syntax-module-path-index-shift(core32_0 s_0 from-mpi_0 to-mpi_0 #f)))"
"((s_0 from-mpi_0 to-mpi_0 inspector28_0)(core32_0 s_0 from-mpi_0 to-mpi_0 inspector28_0))))))"
" syntax-module-path-index-shift_0))"
"(define-values"
"(deserialize-instance)"
@ -71230,7 +71220,7 @@ static const char *startup_source =
"(let-values(((s248_0) s_0)((temp249_0)(list(core-id 'quote phase_0) null)))"
"(rebuild5.1 #t s248_0 temp249_0)))))"
"(let-values()"
"(let-values(((keep-for-parsed?_0)(eq?(system-type 'vm) 'chez-scheme)))"
"(let-values(((keep-for-parsed?_0) keep-source-locations?))"
"(let-values(((rebuild-s_0)"
"(let-values(((ctx250_0) ctx_0)"
"((s251_0) s_0)"

1
racket/src/racket/src/syntax.c
View File

@ -114,6 +114,7 @@ void scheme_init_stx(Scheme_Startup_Env *env)
empty_srcloc->line = -1;
empty_srcloc->col = -1;
empty_srcloc->pos = -1;
empty_srcloc->span = -1;
REGISTER_SO(scheme_paren_shape_symbol);
scheme_paren_shape_symbol = scheme_intern_symbol("paren-shape");

21
racket/src/schemify/quoted.rkt
View File

@ -1,7 +1,9 @@
#lang racket/base
(require racket/extflonum)
(require racket/extflonum
racket/fixnum)
(provide lift-quoted?)
(provide lift-quoted?
large-quoted?)
;; Check whether a quoted value needs to be lifted to run-time construction
(define (lift-quoted? q for-cify? datum-intern?)
@ -31,3 +33,18 @@
[(prefab-struct-key q) #t]
[(extflonum? q) #t]
[else #f])))
;; Check whether a quoted value is large enough to be worth representing
;; in fasl format:
(define (large-quoted? q)
(define fuel
(let remain ([q q] [fuel 128])
(cond
[(fx= fuel 0) 0]
[(pair? q) (remain (cdr q) (remain (car q) (fx- fuel 1)))]
[(vector? q) (for/fold ([fuel (fx- fuel 1)]) ([e (in-vector q)])
(remain e fuel))]
[(box? q) (remain (unbox q) (fx- fuel 1))]
[(prefab-struct-key q) (remain (struct->vector q) fuel)]
[else (fx- fuel 1)])))
(fx= fuel 0))

195
racket/src/schemify/serialize.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/extflonum
racket/prefab
racket/fasl
"match.rkt"
"wrap.rkt"
"path-for-srcloc.rkt"
@ -151,99 +152,105 @@
(set! seen (hash-set seen v #t)))
(define (done-cycle v)
(set! seen (hash-remove seen v)))
(let make-construct ([q q])
(define lifted-constants (if (or (string? q) (bytes? q))
lifted-equal-constants
lifted-eq-constants))
(cond
[(hash-ref lifted-constants q #f)
=> (lambda (id) id)]
[else
(define rhs
(cond
[(path? q)
(if for-cify?
`(bytes->path ,(path->bytes q)
',(path-convention-type q))
;; We expect paths to be recognized in lifted bindings
;; and handled specially, so no conversion here:
q)]
[(path-for-srcloc? q) q]
[(regexp? q)
`(,(if (pregexp? q) 'pregexp 'regexp) ,(object-name q))]
[(srcloc? q)
`(unsafe-make-srcloc
,(let ([src (srcloc-source q)])
(if (and (not for-cify?)
;; Need to handle paths, need to reject (later) anything other
;; than a few type slike strings and byte strings
(not (or (string? src) (bytes? src) (symbol? src) (not src))))
;; Like paths, `path-for-srcloc` must be recognized later
(make-construct (path-for-srcloc src))
(make-construct src)))
,(make-construct (srcloc-line q))
,(make-construct (srcloc-column q))
,(make-construct (srcloc-position q))
,(make-construct (srcloc-span q)))]
[(byte-regexp? q)
`(,(if (byte-pregexp? q) 'byte-pregexp 'byte-regexp) ,(object-name q))]
[(keyword? q)
`(string->keyword ,(keyword->string q))]
[(hash? q)
(define mut? (not (immutable? q)))
(when mut? (check-cycle q))
(define new-q
`(,(cond
[(hash-eq? q) 'hasheq]
[(hash-eqv? q) 'hasheqv]
[else 'hash])
,@(apply append
(for/list ([(k v) (in-hash q)])
(list (make-construct k)
(make-construct v))))))
(when mut? (done-cycle q))
new-q]
[(string? q) `(datum-intern-literal ,q)]
[(bytes? q) `(datum-intern-literal ,q)]
[(pair? q)
(if (list? q)
(let ([args (map make-construct q)])
(if (andmap quote? args)
`(quote ,q)
`(list ,@(map make-construct q))))
(let ([a (make-construct (car q))]
[d (make-construct (cdr q))])
(if (and (quote? a) (quote? d))
`(quote ,q)
`(cons ,a ,d))))]
[(vector? q)
(let ([args (map make-construct (vector->list q))])
`(vector->immutable-vector
,(if (and (andmap quote? args)
(not (impersonator? q)))
`(quote ,q)
`(vector ,@args))))]
[(box? q)
(let ([arg (make-construct (unbox q))])
`(box-immutable ,arg))]
[(prefab-struct-key q)
=> (lambda (key)
(define mut? (not (prefab-key-all-fields-immutable? key)))
(when mut? (check-cycle q))
(define new-q
`(make-prefab-struct ',key ,@(map make-construct
(cdr (vector->list (struct->vector q))))))
(when mut? (done-cycle q))
new-q)]
[(extflonum? q)
`(string->number ,(format "~a" q) 10 'read)]
[else `(quote ,q)]))
(cond
[(and (not for-cify?)
(large-quoted? q))
(add-lifted `(fasl->s-exp/intern
',(s-exp->fasl q)))]
[else
(let make-construct ([q q])
(define lifted-constants (if (or (string? q) (bytes? q))
lifted-equal-constants
lifted-eq-constants))
(cond
[(and (quote? rhs)
(or (not for-cify?)
(not (lift-quoted? (cadr rhs) #t datum-intern?))))
rhs]
[(hash-ref lifted-constants q #f)
=> (lambda (id) id)]
[else
(define id (add-lifted rhs))
(hash-set! lifted-constants q id)
id])])))
(define rhs
(cond
[(path? q)
(if for-cify?
`(bytes->path ,(path->bytes q)
',(path-convention-type q))
;; We expect paths to be recognized in lifted bindings
;; and handled specially, so no conversion here:
q)]
[(path-for-srcloc? q) q]
[(regexp? q)
`(,(if (pregexp? q) 'pregexp 'regexp) ,(object-name q))]
[(srcloc? q)
`(unsafe-make-srcloc
,(let ([src (srcloc-source q)])
(if (and (not for-cify?)
;; Need to handle paths, need to reject (later) anything other
;; than a few type slike strings and byte strings
(not (or (string? src) (bytes? src) (symbol? src) (not src))))
;; Like paths, `path-for-srcloc` must be recognized later
(make-construct (path-for-srcloc src))
(make-construct src)))
,(make-construct (srcloc-line q))
,(make-construct (srcloc-column q))
,(make-construct (srcloc-position q))
,(make-construct (srcloc-span q)))]
[(byte-regexp? q)
`(,(if (byte-pregexp? q) 'byte-pregexp 'byte-regexp) ,(object-name q))]
[(keyword? q)
`(string->keyword ,(keyword->string q))]
[(hash? q)
(define mut? (not (immutable? q)))
(when mut? (check-cycle q))
(define new-q
`(,(cond
[(hash-eq? q) 'hasheq]
[(hash-eqv? q) 'hasheqv]
[else 'hash])
,@(apply append
(for/list ([(k v) (in-hash q)])
(list (make-construct k)
(make-construct v))))))
(when mut? (done-cycle q))
new-q]
[(string? q) `(datum-intern-literal ,q)]
[(bytes? q) `(datum-intern-literal ,q)]
[(pair? q)
(if (list? q)
(let ([args (map make-construct q)])
(if (andmap quote? args)
`(quote ,q)
`(list ,@(map make-construct q))))
(let ([a (make-construct (car q))]
[d (make-construct (cdr q))])
(if (and (quote? a) (quote? d))
`(quote ,q)
`(cons ,a ,d))))]
[(vector? q)
(let ([args (map make-construct (vector->list q))])
`(vector->immutable-vector
,(if (and (andmap quote? args)
(not (impersonator? q)))
`(quote ,q)
`(vector ,@args))))]
[(box? q)
(let ([arg (make-construct (unbox q))])
`(box-immutable ,arg))]
[(prefab-struct-key q)
=> (lambda (key)
(define mut? (not (prefab-key-all-fields-immutable? key)))
(when mut? (check-cycle q))
(define new-q
`(make-prefab-struct ',key ,@(map make-construct
(cdr (vector->list (struct->vector q))))))
(when mut? (done-cycle q))
new-q)]
[(extflonum? q)
`(string->number ,(format "~a" q) 10 'read)]
[else `(quote ,q)]))
(cond
[(and (quote? rhs)
(or (not for-cify?)
(not (lift-quoted? (cadr rhs) #t datum-intern?))))
rhs]
[else
(define id (add-lifted rhs))
(hash-set! lifted-constants q id)
id])]))]))