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

expander: adjust stx serialization for RacketCS

Browse Source 
Get more of the benefit of traditional Racket's lazy bytecode
unmarshaling by using an explicit `fasl->s-exp` stap on the serialized
form of syntax objects. This approach also avoids generating pointless
machine code for constructing the serialized form, effectively using
`fasl->s-exp` as an interpreter. The result is significantly smaller
".zo" files for RacketCS and slightly faater load times.
This commit is contained in:
Matthew Flatt 2018-12-26 06:12:12 -06:00
parent 75c30b4e2e
commit 326e555146
15 changed files with 2034 additions and 1922 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
racket/src/cs/expander.sls
View File

@ -82,6 +82,9 @@
(include "include.ss")
(include-generated "expander.scm")
(define (fasl->s-exp/intern s)
(1/fasl->s-exp/intern s))
;; ----------------------------------------
;; The environment is used to evaluate linklets, so all primitives
@ -172,6 +175,9 @@
[(_ name val) #`(let ([name val]) name)])))
(eval `(define raise-binding-result-arity-error ',raise-binding-result-arity-error)))
;; Special "primitive" for syntax-data deserialization:
(eval `(define fasl->s-exp/intern ',fasl->s-exp/intern))
;; For interpretation of the outer shell of a linklet:
(install-linklet-primitive-tables! kernel-table
unsafe-table
@ -185,7 +191,7 @@
linklet-table
internal-table
schemify-table)
;; ----------------------------------------
;; `install-reader!` is from the `io` library, where the

1
racket/src/cs/linklet.sls
View File

@ -423,6 +423,7 @@
(define-values (impl-lam importss exports new-import-keys importss-abi exports-info)
(schemify-linklet (show "linklet" c)
serializable?
(not (#%memq 'uninterned-literal options))
jitify-mode?
(|#%app| compile-allow-set!-undefined)
#f ;; safe mode

4
racket/src/cs/primitive/internal.ss
View File

@ -33,4 +33,6 @@
[fork-place (known-procedure 1)]
[start-place (known-procedure 32)]
[make-pthread-parameter (known-procedure 2)])
[make-pthread-parameter (known-procedure 2)]
[fasl->s-exp/intern (known-procedure 2)])

7
racket/src/expander/common/fasl.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(require racket/fasl)
(provide fasl->s-exp/intern)
(define (fasl->s-exp/intern s)
(fasl->s-exp s #:datum-intern? #t))

3
racket/src/expander/compile/built-in-symbol.rkt
View File

@ -62,4 +62,5 @@
annotation-expression
#%app
#%call-with-values
make-pthread-parameter))))
make-pthread-parameter
fasl->s-exp/intern))))

2
racket/src/expander/compile/module.rkt
View File

@ -265,7 +265,7 @@
(make-correlated-linklet s 'syntax-literals-data)
(performance-region
['compile 'module 'linklet]
(compile-linklet s 'syntax-literals-data))))
(compile-linklet s 'syntax-literals-data #f #f '(serializable uninterned-literal)))))
`(linklet
;; imports
(,deserialize-imports

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

@ -1,5 +1,6 @@
#lang racket/base
(require (for-syntax racket/base)
racket/fasl
"serialize-property.rkt"
"serialize-state.rkt"
"../common/set.rkt"
@ -603,20 +604,47 @@
(for ([i (in-range (hash-count mutables))])
(ser-shell-fill! (hash-ref rev-mutables i)))
(reap-stream!)))
;; Final result:
(define result
(begin
(ser-push! v)
(reap-stream!)))
;; Put it all together:
`(deserialize
,mpi-vector-id
,(if syntax-support? inspector-id #f)
,(if syntax-support? bulk-binding-registry-id #f)
',(hash-count mutables)
',mutable-shell-bindings
',(hash-count shares)
',shared-bindings
',mutable-fills
',(begin
(ser-push! v)
(reap-stream!))))
(define (finish mutable-shell-bindings-expr shared-bindings-expr mutable-fills-expr result-expr)
`(deserialize
,mpi-vector-id
,(if syntax-support? inspector-id #f)
,(if syntax-support? bulk-binding-registry-id #f)
',(hash-count mutables)
,mutable-shell-bindings-expr
',(hash-count shares)
,shared-bindings-expr
,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 constructionx, 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)]))
(define (sorted-hash-keys ht)
(define ks (hash-keys ht))

3
racket/src/expander/main.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "common/set.rkt"
"common/fasl.rkt"
"common/module-path.rkt"
"namespace/namespace.rkt"
"eval/main.rkt"
@ -116,6 +117,8 @@
expander-place-init!
fasl->s-exp/intern
;; The remaining functions are provided for basic testing
;; (such as "demo.rkt")

2
racket/src/racket/src/cify-startup.rkt
View File

@ -64,7 +64,7 @@
(printf "Serializable...\n")
(define-values (bodys/constants-lifted lifted-constants)
(time (convert-for-serialize l #t)))
(time (convert-for-serialize l #t #t)))
;; Startup code reuses names to keep it compact; make
;; te names unique again

12
racket/src/racket/src/linklet.c
View File

@ -38,6 +38,7 @@ static Scheme_Object *serializable_symbol;
static Scheme_Object *unsafe_symbol;
static Scheme_Object *static_symbol;
static Scheme_Object *use_prompt_symbol;
static Scheme_Object *uninterned_literal_symbol;
static Scheme_Object *constant_symbol;
static Scheme_Object *consistent_symbol;
static Scheme_Object *noncm_symbol;
@ -124,10 +125,12 @@ void scheme_init_linklet(Scheme_Startup_Env *env)
REGISTER_SO(unsafe_symbol);
REGISTER_SO(static_symbol);
REGISTER_SO(use_prompt_symbol);
REGISTER_SO(uninterned_literal_symbol);
serializable_symbol = scheme_intern_symbol("serializable");
unsafe_symbol = scheme_intern_symbol("unsafe");
static_symbol = scheme_intern_symbol("static");
use_prompt_symbol = scheme_intern_symbol("use-prompt");
uninterned_literal_symbol = scheme_intern_symbol("uninterned-literal");
REGISTER_SO(constant_symbol);
REGISTER_SO(consistent_symbol);
@ -379,6 +382,7 @@ static void parse_compile_options(const char *who, int arg_pos,
int unsafe = *_unsafe;
int static_mode = *_static_mode;
int use_prompt_mode = 0;
int uninterned_literal_mode = 0;
while (SCHEME_PAIRP(flags)) {
flag = SCHEME_CAR(flags);
@ -398,13 +402,19 @@ static void parse_compile_options(const char *who, int arg_pos,
if (use_prompt_mode && !redundant)
redundant = flag;
use_prompt_mode = 1;
} else if (SAME_OBJ(flag, uninterned_literal_symbol)) {
if (uninterned_literal_mode && !redundant)
redundant = flag;
uninterned_literal_mode = 1;
} else
break;
flags = SCHEME_CDR(flags);
}
if (!SCHEME_NULLP(flags))
scheme_wrong_contract("compile-linklet", "(listof/c 'serializable 'unsafe 'static 'use-prompt)", arg_pos, argc, argv);
scheme_wrong_contract("compile-linklet",
"(listof/c 'serializable 'unsafe 'static 'use-prompt 'uninterned-literal)",
arg_pos, argc, argv);
if (redundant)
scheme_contract_error("compile-linklet", "redundant option",

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

File diff suppressed because it is too large Load Diff

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

@ -4,29 +4,30 @@
(provide lift-quoted?)
;; Check whether a quoted value needs to be lifted to run-time construction
(define (lift-quoted? q for-cify?)
(cond
[for-cify?
(not (or (and (exact-integer? q)
;; always a fixnum:
(<= (- (expt 2 29)) q (expt 2 29)))
(boolean? q)
(null? q)
(void? q)))]
[(impersonator? q) #t] ; i.e., strip impersonators when serializaing
[(path? q) #t]
[(regexp? q) #t]
[(srcloc? q) #t]
[(byte-regexp? q) #t]
[(keyword? q) #t]
[(hash? q) #t]
[(string? q) #t]
[(bytes? q) #t]
[(pair? q) (or (lift-quoted? (car q) for-cify?)
(lift-quoted? (cdr q) for-cify?))]
[(vector? q) (for/or ([e (in-vector q)])
(lift-quoted? e for-cify?))]
[(box? q) (lift-quoted? (unbox q) for-cify?)]
[(prefab-struct-key q) #t]
[(extflonum? q) #t]
[else #f]))
(define (lift-quoted? q for-cify? datum-intern?)
(let lift-quoted? ([q q])
(cond
[for-cify?
(not (or (and (exact-integer? q)
;; always a fixnum:
(<= (- (expt 2 29)) q (expt 2 29)))
(boolean? q)
(null? q)
(void? q)))]
[(impersonator? q) #t] ; i.e., strip impersonators when serializaing
[(path? q) #t]
[(regexp? q) #t]
[(srcloc? q) #t]
[(byte-regexp? q) #t]
[(keyword? q) #t]
[(hash? q) #t]
[(string? q) datum-intern?]
[(bytes? q) datum-intern?]
[(pair? q) (or (lift-quoted? (car q))
(lift-quoted? (cdr q)))]
[(vector? q) (for/or ([e (in-vector q)])
(lift-quoted? e))]
[(box? q) (lift-quoted? (unbox q))]
[(prefab-struct-key q) #t]
[(extflonum? q) #t]
[else #f])))

4
racket/src/schemify/schemify.rkt
View File

@ -61,7 +61,7 @@
;; An import ABI is a list of list of booleans, parallel to the
;; linklet imports, where #t to means that a value is expected, and #f
;; means that a variable (which boxes a value) is expected
(define (schemify-linklet lk serializable? for-jitify? allow-set!-undefined?
(define (schemify-linklet lk serializable? datum-intern? for-jitify? allow-set!-undefined?
unsafe-mode? no-prompt?
prim-knowns get-import-knowns import-keys)
(define (im-int-id id) (unwrap (if (pair? id) (cadr id) id)))
@ -113,7 +113,7 @@
;; Lift any quoted constants that can't be serialized
(define-values (bodys/constants-lifted lifted-constants)
(if serializable?
(convert-for-serialize bodys #f)
(convert-for-serialize bodys #f datum-intern?)
(values bodys null)))
;; Schemify the body, collecting information about defined names:
(define-values (new-body defn-info mutated)

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

@ -16,7 +16,7 @@
;; reference. This lifting can interefere with optimizations, so only
;; lift as a last resort.
(define (convert-for-serialize bodys for-cify?)
(define (convert-for-serialize bodys for-cify? datum-intern?)
(define lifted-eq-constants (make-hasheq))
(define lifted-equal-constants (make-hash))
(define lift-bindings null)
@ -30,15 +30,16 @@
(define new-bodys
(for/list ([v (in-list bodys)])
(cond
[(convert-any? v for-cify?)
[(convert-any? v for-cify? datum-intern?)
(define (convert v)
(reannotate
v
(match v
[`(quote ,q)
(cond
[(lift-quoted? q for-cify?)
(make-construct q add-lifted lifted-eq-constants lifted-equal-constants for-cify?)]
[(lift-quoted? q for-cify? datum-intern?)
(make-construct q add-lifted lifted-eq-constants lifted-equal-constants
for-cify? datum-intern?)]
[else v])]
[`(lambda ,formals ,body ...)
`(lambda ,formals ,@(convert-function-body body))]
@ -76,7 +77,7 @@
(cond
[(and for-cify?
(not (symbol? v))
(lift-quoted? v for-cify?))
(lift-quoted? v for-cify? datum-intern?))
(convert `(quote ,v))]
[else v])])))
(define (convert-body body)
@ -97,10 +98,10 @@
(reverse lift-bindings)))
;; v is a form or a list of forms
(define (convert-any? v for-cify?)
(define (convert-any? v for-cify? datum-intern?)
(let convert-any? ([v v])
(match v
[`(quote ,q) (lift-quoted? q for-cify?)]
[`(quote ,q) (lift-quoted? q for-cify? datum-intern?)]
[`(lambda ,formals ,body ...)
(convert-any? body)]
[`(case-lambda [,formalss ,bodys ...] ...)
@ -134,10 +135,11 @@
(convert-any? exp))]
[`,_ (and for-cify?
(not (symbol? v))
(lift-quoted? v for-cify?))])))
(lift-quoted? v for-cify? datum-intern?))])))
;; Construct an expression to be lifted
(define (make-construct q add-lifted lifted-eq-constants lifted-equal-constants for-cify?)
(define (make-construct q add-lifted lifted-eq-constants lifted-equal-constants
for-cify? datum-intern?)
(define (quote? e) (and (pair? e) (eq? 'quote (car e))))
(let make-construct ([q q])
(define lifted-constants (if (or (string? q) (bytes? q))
@ -206,7 +208,7 @@
(cond
[(and (quote? rhs)
(or (not for-cify?)
(not (lift-quoted? (cadr rhs) #t))))
(not (lift-quoted? (cadr rhs) #t datum-intern?))))
rhs]
[else
(define id (add-lifted rhs))

2
racket/src/schemify/size.rkt
View File

@ -37,7 +37,7 @@
[`(begin0 . ,body)
(body-leftover-size body (sub1 size))]
[`(quote ,v) (if (and serializable?
(lift-quoted? v #f))
(lift-quoted? v #f #t))
;; pessimistically assume that full
;; strcuture must be lifted for
;; serialization: