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

repairs for change for machine-independent bytecode

Browse Source 
Fix problems with moving some VM-specific handlign to schemify, and
fix some interning issues that the change exposed.
This commit is contained in:
Matthew Flatt 2019-03-12 12:13:12 -06:00
parent df8501d8f0
commit 6a35d64e95
13 changed files with 507 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -759,7 +759,7 @@
(struct faslable-correlated-linklet (expr name)
#:prefab)
(struct faslable-correlated (e source position line column span name)
(struct faslable-correlated (e source position line column span props)
#:prefab)
(define (strip-correlated v)

366
racket/collects/racket/private/c.rkt Normal file
View File

@ -0,0 +1,366 @@
;;----------------------------------------------------------------------
;; case: based on Clinger, "Rapid Case Dispatch in Scheme"
;; [http://scheme2006.cs.uchicago.edu/07-clinger.pdf]
(module case '#%kernel
(#%require '#%paramz '#%unsafe "small-scheme.rkt" "define.rkt"
(for-syntax '#%kernel "small-scheme.rkt" "stxcase-scheme.rkt"
"qqstx.rkt" "define.rkt" "sort.rkt"))
(#%provide case)
(define-syntax (case stx)
(syntax-case stx (else)
;; Empty case
[(_ v)
(syntax-protect
(syntax/loc stx (#%expression (begin v (void)))))]
;; Else-only case
[(_ v [else e es ...])
(syntax-protect
(syntax/loc stx (#%expression (begin v (let-values () e es ...)))))]
;; If we have a syntactically correct form without an 'else' clause,
;; add the default 'else' and try again.
[(self v [(k ...) e1 e2 ...] ...)
(syntax-protect
(syntax/loc stx (self v [(k ...) e1 e2 ...] ... [else (void)])))]
;; The general case
[(_ v [(k ...) e1 e2 ...] ... [else x1 x2 ...])
(syntax-protect
(if (< (length (syntax-e #'(k ... ...))) *sequential-threshold*)
(syntax/loc stx (let ([tmp v])
(case/sequential tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))
(syntax/loc stx (let ([tmp v])
(case/dispatch tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))))]
;; Error cases
[(_ v clause ...)
(let loop ([clauses (syntax->list #'(clause ...))])
(unless (null? clauses)
(let ([clause (car clauses)])
(syntax-case clause ()
[((_ ...) _ _ ...)
(loop (cdr clauses))]
[((_ ...) . _)
(syntax-case clause ()
[(_)
(raise-syntax-error
#f
"bad syntax (missing expression after datum sequence)"
stx
clause)]
[(_ . _)
(raise-syntax-error
#f
"bad syntax (illegal use of `.' in clause)"
stx
clause)]
[_
(raise-syntax-error
#f
"bad syntax (ill-formed clause)"
stx
clause)])]
[(bad . _)
(raise-syntax-error
#f
;; If #'bad is an identifier, report its binding in the error message.
;; This helps resolving the syntax error when `else' is shadowed somewhere
(if (not (symbol? (syntax-e (syntax bad))))
"bad syntax (not a datum sequence)"
(string-append
"bad syntax (not a datum sequence)\n"
" expected: a datum sequence or the binding 'else' from racket/base\n"
" given: "
(let ([binding (identifier-binding (syntax bad))])
(cond
[(not binding) "an unbound identifier"]
[(eq? binding 'lexical) "a locally bound identifier"]
[else
(let*-values ([(src) (car binding)]
[(mpath base) (module-path-index-split src)])
(cond
[(not mpath)
"an identifier bound by the current module"]
[else
(format "an identifier required from the module ~a"
(resolved-module-path-name
(module-path-index-resolve src)))]))]))))
stx
(syntax bad))]
[_
(raise-syntax-error
#f
"bad syntax (ill-formed clause)"
stx
(syntax bad))]))))]
[(_ . v)
(not (null? (syntax-e (syntax v))))
(raise-syntax-error
#f
"bad syntax (illegal use of `.')"
stx)]))
;; Sequential case:
;; Turn the expression into a sequence of if-then-else.
(define-syntax (case/sequential stx)
(syntax-case stx (else)
[(_ v [(k ...) es ...] arms ... [else xs ...])
(syntax-protect
#'(if (case/sequential-test v (k ...))
(let-values () es ...)
(case/sequential v arms ... [else xs ...])))]
[(_ v [(k ...) es ...] [else xs ...])
(syntax-protect
#'(if (case/sequential-test v (k ...))
(let-values () es ...)
(let-values () xs ...)))]
[(_ v [else xs ...])
(syntax-protect
#'(let-values () xs ...))]))
(define-syntax (case/sequential-test stx)
(syntax-protect
(syntax-case stx ()
[(_ v ()) #'#f]
[(_ v (k)) #`(equal? v 'k)]
[(_ v (k ks ...)) #`(if (equal? v 'k)
#t
(case/sequential-test v (ks ...)))])))
;; Triple-dispatch case:
;; (1) From the type of the value to a type-specific mechanism for
;; (2) mapping the value to the index of the consequent we need. Then,
;; (3) from the index, perform a binary search to find the consequent code.
;; Note: the else clause is given index 0.
(define-syntax (case/dispatch stx)
(syntax-case stx (else)
[(_ v [(k ...) es ...] ... [else xs ...])
(syntax-protect
#`(let ([index
#,(let* ([ks (partition-constants #'((k ...) ...))]
[exp #'0]
[exp (if (null? (consts-other ks))
exp
(dispatch-other #'v (consts-other ks) exp))]
[exp (if (null? (consts-char ks))
exp
#`(if (char? v)
#,(dispatch-char #'v (consts-char ks))
#,exp))]
[exp (if (null? (consts-symbol ks))
exp
#`(if #,(test-for-symbol #'v (consts-symbol ks))
#,(dispatch-symbol #'v (consts-symbol ks) #'0)
#,exp))]
[exp (if (null? (consts-fixnum ks))
exp
#`(if (fixnum? v)
#,(dispatch-fixnum #'v (consts-fixnum ks))
#,exp))])
exp)])
#,(index-binary-search #'index #'([xs ...] [es ...] ...))))]))
(begin-for-syntax
(define *sequential-threshold* 12)
(define *hash-threshold* 10)
(define nothing (gensym))
(define interval-lo car)
(define interval-hi cadr)
(define interval-index caddr)
(define (partition-constants stx)
(define h (make-hash))
(define (duplicate? x)
(not (eq? (hash-ref h x nothing) nothing)))
(define (add xs x idx)
(hash-set! h x idx)
(cons (cons x idx) xs))
(let loop ([f '()] [s '()] [c '()] [o '()] [idx 1] [xs (syntax->list stx)])
(cond [(null? xs)
(list (cons 'fixnum f)
(cons 'symbol s)
(cons 'char c)
(cons 'other o))]
[else (let inner ([f f] [s s] [c c] [o o] [ys (syntax->list (car xs))])
(cond [(null? ys) (loop f s c o (add1 idx) (cdr xs))]
[else
(let ([y (syntax->datum (car ys))])
(cond [(duplicate? y) (inner f s c o (cdr ys))]
[(fixnum? y) (inner (add f y idx) s c o (cdr ys))]
[(symbol? y) (inner f (add s y idx) c o (cdr ys))]
[(keyword? y) (inner f (add s y idx) c o (cdr ys))]
[(char? y) (inner f s (add c y idx) o (cdr ys))]
[else (inner f s c (add o y idx) (cdr ys))]))]))])))
(define (consts-fixnum ks) (cdr (assq 'fixnum ks)))
(define (consts-symbol ks) (cdr (assq 'symbol ks)))
(define (consts-char ks) (cdr (assq 'char ks)))
(define (consts-other ks) (cdr (assq 'other ks)))
;; Character dispatch is fixnum dispatch.
(define (dispatch-char tmp-stx char-alist)
#`(let ([codepoint (char->integer #,tmp-stx)])
#,(dispatch-fixnum #'codepoint
(map (λ (x)
(cons (char->integer (car x))
(cdr x)))
char-alist))))
;; Symbol and "other" dispatch is either sequential or
;; hash-table-based, depending on how many constants we
;; have. Assume that `alist' does not map anything to `#f'.
(define (dispatch-hashable tmp-stx alist make-hashX else-exp)
(if (< (length alist) *hash-threshold*)
#`(case/sequential #,tmp-stx
#,@(map (λ (x)
#`[(#,(car x)) #,(cdr x)])
alist)
[else #,else-exp])
(let ([tbl (make-hashX alist)])
(if (literal-expression? else-exp)
#`(hash-ref #,tbl #,tmp-stx (lambda () #,else-exp))
#`(or (hash-ref #,tbl #,tmp-stx (lambda () #f))
#,else-exp)))))
(define (dispatch-symbol tmp-stx symbol-alist else-exp)
(dispatch-hashable tmp-stx symbol-alist make-immutable-hasheq else-exp))
(define (dispatch-other tmp-stx other-alist else-exp)
(dispatch-hashable tmp-stx other-alist make-immutable-hash else-exp))
(define (test-for-symbol tmp-stx alist)
(define (contains? pred)
(ormap (lambda (p) (pred (car p))) alist))
(if (contains? symbol?)
(if (contains? keyword?)
#`(or (symbol? #,tmp-stx) (keyword? #,tmp-stx))
#`(symbol? #,tmp-stx))
#`(keyword? #,tmp-stx)))
(define (literal-expression? else-exp)
(define v (syntax-e else-exp))
(or (boolean? v) (number? v)))
;; Fixnum dispatch is either table lookup or binary search.
(define (dispatch-fixnum tmp-stx fixnum-alist)
(define (go intervals lo hi lo-bound hi-bound)
(define len (length intervals))
(cond [(or (>= lo-bound hi)
(<= hi-bound lo))
#'0]
[(and (> len 1)
(< (- hi lo) (* len 5)))
(fixnum-table-lookup intervals lo hi lo-bound hi-bound)]
[else
(fixnum-binary-search intervals lo hi lo-bound hi-bound)]))
(define (fixnum-table-lookup intervals lo hi lo-bound hi-bound)
(define index-lists
(map (λ (int)
(vector->list
(make-vector (- (interval-hi int)
(interval-lo int))
(interval-index int))))
intervals))
#`(let ([tbl #,(list->vector (apply append index-lists))])
#,(bounded-expr tmp-stx lo hi lo-bound hi-bound
#`(unsafe-vector*-ref tbl (unsafe-fx- #,tmp-stx #,lo)))))
(define (fixnum-binary-search intervals lo hi lo-bound hi-bound)
(cond [(null? (cdr intervals))
#`#,(interval-index (car intervals))]
[else
(define-values (lo-ints hi-ints) (split-intervals intervals))
(define-values (lo-lo lo-hi) (lo+hi lo-ints))
(define-values (hi-lo hi-hi) (lo+hi hi-ints))
#`(if (unsafe-fx< #,tmp-stx #,hi-lo)
#,(go lo-ints lo-lo lo-hi lo-bound hi-lo)
#,(go hi-ints hi-lo hi-hi hi-lo hi-bound))]))
(define (split-intervals intervals)
(define n (quotient (length intervals) 2))
(let loop ([n n] [lo '()] [hi intervals])
(cond [(zero? n) (values (reverse lo) hi)]
[else (loop (sub1 n) (cons (car hi) lo) (cdr hi))])))
(define (lo+hi intervals)
(values (interval-lo (car intervals))
(interval-hi (car (reverse intervals)))))
(define intervals (alist->intervals fixnum-alist))
(define-values (lo hi) (lo+hi intervals))
#`(if (and (unsafe-fx>= #,tmp-stx #,lo)
(unsafe-fx< #,tmp-stx #,hi))
#,(go intervals lo hi lo hi)
0))
;; Once we have the index of the consequent we want, perform
;; a binary search to find it.
(define (index-binary-search index-stx leg-stx)
(define legs (list->vector (syntax->list leg-stx)))
(define (go min max)
(cond [(= min max)
#`(let-values () #,@(vector-ref legs min))]
[(= max (add1 min))
#`(if (unsafe-fx< #,index-stx #,max)
(let-values () #,@(vector-ref legs min))
(let-values () #,@(vector-ref legs max)))]
[else
(let ([mid (quotient (+ min max) 2)])
#`(if (unsafe-fx< #,index-stx #,mid)
#,(go min (sub1 mid))
#,(go mid max)))]))
(go 0 (sub1 (vector-length legs))))
(define (bounded-expr tmp-stx lo hi lo-bound hi-bound exp-stx)
(cond [(and (<= hi-bound hi)
(>= lo-bound lo))
exp-stx]
[(<= hi-bound hi)
#`(if (unsafe-fx>= #,tmp-stx #,lo) exp-stx 0)]
[(>= lo-bound lo)
#`(if (unsafe-fx< #,tmp-stx #,hi) exp-stx 0)]
[else
#`(if (and (unsafe-fx>= #,tmp-stx #,lo)
(unsafe-fx< #,tmp-stx #,hi))
exp-stx
0)]))
(define (alist->intervals alist)
(let loop ([xs (sort alist < car)] [start-idx #f] [end-idx #f] [cur-val #f] [res '()])
(cond [(null? xs)
(if start-idx
(reverse (cons (list start-idx end-idx cur-val) res))
'())]
[else
(let* ([x (car xs)]
[k (car x)]
[v (cdr x)])
(cond [(not start-idx)
(loop (cdr xs) k (add1 k) v res)]
[(and (= end-idx k) (= cur-val v))
(loop (cdr xs) start-idx (add1 end-idx) cur-val res)]
[(= end-idx k)
(let ([interval (list start-idx end-idx cur-val)])
(loop (cdr xs) k (add1 k) v (cons interval res)))]
[else
;; insert an interval in the gap for the default
(let ([int1 (list start-idx end-idx cur-val)]
[int2 (list end-idx k 0)])
(loop (cdr xs) k (add1 k) v (cons int2 (cons int1 res))))]))])))))

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

@ -28,7 +28,9 @@
(thread)
(regexp)
(io)
(linklet))
(linklet)
(only (schemify)
force-unfasl))
(include "place-register.ss")
(define-place-register-define define expander-register-start expander-register-count)
@ -38,9 +40,6 @@
;; the build incompatible with previously generated ".zo" files.
(define compile-as-independent? #f)
(define (fasl->s-exp/intern s)
(1/fasl->s-exp/intern s))
;; The expander needs various tables to set up primitive modules, and
;; the `primitive-table` function is the bridge between worlds
@ -113,7 +112,9 @@
(thread)
(io)
(regexp)
(linklet)))
(linklet)
(only (schemify)
force-unfasl)))
;; Ensure that the library is visited, especially for a wpo build:
(eval 'variable-set!)))
@ -181,9 +182,6 @@
[(_ 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

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

@ -36,4 +36,4 @@
[make-pthread-parameter (known-procedure 2)]
[break-enabled-key (known-constant)]
[fasl->s-exp/intern (known-procedure 2)])
[force-unfasl (known-procedure 2)])

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

@ -9,6 +9,7 @@
linklet-bigger-than?
make-path->compiled-path
compiled-path->path
force-unfasl
prim-knowns
known-procedure
known-procedure/pure

19
racket/src/expander/compile/correlated-linklet.rkt
View File

@ -53,7 +53,7 @@
(define correlated-linklet-vm-bytes #"linklet")
(struct faslable-correlated (e source position line column span name)
(struct faslable-correlated (e source position line column span props)
#:prefab)
(struct faslable-correlated-linklet (expr name)
@ -81,7 +81,13 @@
(correlated-line v)
(correlated-column v)
(correlated-span v)
(correlated-property v 'inferred-name))]
(for/fold ([ht #f]) ([k (in-list '(inferred-name
undefined-error-name
method-arity-error))])
(define p (correlated-property v k))
(if p
(hash-set (or ht '#hasheq()) k p)
ht)))]
[(hash? v)
(cond
[(hash-eq? v)
@ -101,7 +107,7 @@
;; ----------------------------------------
(define (read-correlated-linklet-bundle-hash in)
(faslable-> (fasl->s-exp in)))
(faslable-> (fasl->s-exp in #:datum-intern? #t)))
(define (faslable-> v)
(cond
@ -113,7 +119,7 @@
v
(cons a d))]
[(faslable-correlated? v)
(define name (faslable-correlated-name v))
(define props (faslable-correlated-props v))
(define c (datum->correlated (faslable-> (faslable-correlated-e v))
(vector
(faslable-correlated-source v)
@ -121,8 +127,9 @@
(faslable-correlated-column v)
(faslable-correlated-position v)
(faslable-correlated-span v))))
(if name
(correlated-property c 'inferred-name name)
(if props
(for/fold ([c c]) ([(k p) (in-hash props)])
(correlated-property c k p))
c)]
[(hash? v)
(cond

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 #f #f '(serializable uninterned-literal)))))
(compile-linklet s 'syntax-literals-data #f #f '(serializable)))))
`(linklet
;; imports
(,deserialize-imports

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

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

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

@ -28732,7 +28732,7 @@ static const char *startup_source =
" faslable-correlated-line"
" faslable-correlated-column"
" faslable-correlated-span"
" faslable-correlated-name)"
" faslable-correlated-props)"
"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
"(let-values()"
"(let-values()"
@ -28758,7 +28758,7 @@ static const char *startup_source =
"(make-struct-field-accessor -ref_0 3 'line)"
"(make-struct-field-accessor -ref_0 4 'column)"
"(make-struct-field-accessor -ref_0 5 'span)"
"(make-struct-field-accessor -ref_0 6 'name))))"
"(make-struct-field-accessor -ref_0 6 'props))))"
"(define-values"
"(struct:faslable-correlated-linklet"
" faslable-correlated-linklet3.1"
@ -28808,7 +28808,34 @@ static const char *startup_source =
"(correlated-line v_0)"
"(correlated-column v_0)"
"(correlated-span v_0)"
"(correlated-property v_0 'inferred-name)))"
"(let-values(((lst_0) '(inferred-name undefined-error-name method-arity-error)))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_0)))"
"((letrec-values(((for-loop_0)"
"(lambda(ht_0 lst_1)"
"(begin"
" 'for-loop"
"(if(pair? lst_1)"
"(let-values(((k_0)(unsafe-car lst_1))((rest_0)(unsafe-cdr lst_1)))"
"(let-values(((ht_1)"
"(let-values(((ht_1) ht_0))"
"(let-values(((ht_2)"
"(let-values()"
"(let-values(((p_0)"
"(correlated-property v_0 k_0)))"
"(if p_0"
"(hash-set"
"(let-values(((or-part_0) ht_1))"
"(if or-part_0 or-part_0 '#hasheq()))"
" k_0"
" p_0)"
" ht_1)))))"
"(values ht_2)))))"
"(if(not #f)(for-loop_0 ht_1 rest_0) ht_1)))"
" ht_0)))))"
" for-loop_0)"
" #f"
" lst_0)))))"
"(if(hash? v_0)"
"(let-values()"
"(if(hash-eq? v_0)"
@ -28914,7 +28941,7 @@ static const char *startup_source =
"(let-values() v_0))))))))"
"(define-values"
"(read-correlated-linklet-bundle-hash)"
"(lambda(in_0)(begin(faslable->(let-values(((in9_0) in_0))(fasl->s-exp17.1 #t in9_0))))))"
"(lambda(in_0)(begin(faslable->(let-values(((in9_0) in_0)((temp10_0) #t))(fasl->s-exp17.1 temp10_0 in9_0))))))"
"(define-values"
"(faslable->)"
"(lambda(v_0)"
@ -28926,7 +28953,7 @@ static const char *startup_source =
"(if(if(eq? a_0(car v_0))(eq? d_0(cdr v_0)) #f) v_0(cons a_0 d_0)))))"
"(if(faslable-correlated? v_0)"
"(let-values()"
"(let-values(((name_0)(faslable-correlated-name v_0)))"
"(let-values(((props_0)(faslable-correlated-props v_0)))"
"(let-values(((c_0)"
"(datum->correlated"
"(faslable->(faslable-correlated-e v_0))"
@ -28936,7 +28963,30 @@ static const char *startup_source =
"(faslable-correlated-column v_0)"
"(faslable-correlated-position v_0)"
"(faslable-correlated-span v_0)))))"
"(if name_0(correlated-property c_0 'inferred-name name_0) c_0))))"
"(if props_0"
"(let-values(((ht_0) props_0))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))"
"(void)"
"(let-values()(check-in-hash ht_0)))"
"((letrec-values(((for-loop_0)"
"(lambda(c_1 i_0)"
"(begin"
" 'for-loop"
"(if i_0"
"(let-values(((k_0 p_0)(hash-iterate-key+value ht_0 i_0)))"
"(let-values(((c_2)"
"(let-values(((c_2) c_1))"
"(let-values(((c_3)"
"(let-values()"
"(correlated-property c_2 k_0 p_0))))"
"(values c_3)))))"
"(if(not #f)(for-loop_0 c_2(hash-iterate-next ht_0 i_0)) c_2)))"
" c_1)))))"
" for-loop_0)"
" c_0"
"(hash-iterate-first ht_0))))"
" c_0))))"
"(if(hash? v_0)"
"(let-values()"
"(if(hash-eq? v_0)"
@ -39653,8 +39703,7 @@ static const char *startup_source =
" 'syntax-literals-data"
" #f"
" #f"
" '(serializable"
" uninterned-literal)))"
" '(serializable)))"
"(if log-performance?"
"(let-values()"
"(end-performance-region))"

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

@ -4,6 +4,7 @@
"match.rkt"
"wrap.rkt"
"path-for-srcloc.rkt"
"to-fasl.rkt"
"interp-match.rkt"
"interp-stack.rkt")
@ -84,7 +85,8 @@
(let ([rhs (cadr binding)])
(cons (cond
[(or (path? rhs)
(path-for-srcloc? rhs))
(path-for-srcloc? rhs)
(to-fasl? rhs))
;; The caller must extract all the paths from the bindings
;; and pass them back in at interp time; assume '#%path is
;; not a primitive

64
racket/src/schemify/path.rkt
View File

@ -1,12 +1,15 @@
#lang racket/base
(require racket/private/relative-path
racket/private/truncate-path
racket/fasl
"match.rkt"
"path-for-srcloc.rkt")
"path-for-srcloc.rkt"
"to-fasl.rkt")
(provide extract-paths-from-schemified-linklet
make-path->compiled-path
compiled-path->path)
compiled-path->path
force-unfasl)
;; Recognize lifted paths in a schemified linklet, and
;; return the list of path values. If `convert?`, then
@ -20,7 +23,7 @@
[`(let* ,bindings ,body)
(define (path-binding? b)
(define rhs (cadr b))
(or (path? rhs) (path-for-srcloc? rhs)))
(or (path? rhs) (path-for-srcloc? rhs) (to-fasl? rhs)))
(define any-path?
(for/or ([b (in-list bindings)])
(path-binding? b)))
@ -48,28 +51,49 @@
(define (make-path->compiled-path who)
(define path->relative-path-elements (make-path->relative-path-elements #:who who))
(lambda (orig-p)
(define p (if (path-for-srcloc? orig-p)
(path-for-srcloc-path orig-p)
orig-p))
(cond
[(path? p)
(or (path->relative-path-elements p)
(cond
[(path-for-srcloc? orig-p)
;; Can't make relative, so create a string that keeps up
;; to two path elements
(truncate-path p)]
[else (path->bytes p)]))]
[(or (string? p) (bytes? p) (symbol? p) (not p))
;; Allowed in compiled form
p]
[(to-fasl? orig-p)
(box (s-exp->fasl (force-unfasl orig-p)))]
[else
(error 'write
"cannot marshal value that is embedded in compiled code: ~V"
p)])))
(define p (if (path-for-srcloc? orig-p)
(path-for-srcloc-path orig-p)
orig-p))
(cond
[(path? p)
(or (path->relative-path-elements p)
(cond
[(path-for-srcloc? orig-p)
;; Can't make relative, so create a string that keeps up
;; to two path elements
(truncate-path p)]
[else (path->bytes p)]))]
[(or (string? p) (bytes? p) (symbol? p) (not p))
;; Allowed in compiled form
p]
[else
(error 'write
"cannot marshal value that is embedded in compiled code: ~V"
p)])])))
(define (compiled-path->path e)
(cond
[(box? e) (to-fasl (box (unbox e))
(or (current-load-relative-directory)
(current-directory)))]
[(bytes? e) (bytes->path e)]
[(string? e) e] ; was `path-for-srcloc` on write
[else (relative-path-elements->path e)]))
(define (force-unfasl tf)
(define vb (to-fasl-vb tf))
(define v (unbox vb))
(cond
[(bytes? v)
(define v2 (parameterize ([current-load-relative-directory (to-fasl-wrt tf)])
(fasl->s-exp v #:datum-intern? #t)))
(box-cas! vb v v2)
(set-to-fasl-wrt! tf #f)
(unbox vb)]
[else
;; already forced (or never fasled)
v]))

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

@ -1,10 +1,10 @@
#lang racket/base
(require racket/extflonum
racket/prefab
racket/fasl
"match.rkt"
"wrap.rkt"
"path-for-srcloc.rkt"
"to-fasl.rkt"
"quoted.rkt")
(provide convert-for-serialize)
@ -78,8 +78,7 @@
`(,(convert rator) ,@(convert-body exps))]
[`,_
(cond
[(and for-cify?
(not (symbol? v))
[(and (not (symbol? v))
(lift-quoted? v for-cify? datum-intern?))
(convert `(quote ,v))]
[else v])])))
@ -136,8 +135,7 @@
[`(,exps ...)
(for/or ([exp (in-list exps)])
(convert-any? exp))]
[`,_ (and for-cify?
(not (symbol? v))
[`,_ (and (not (symbol? v))
(lift-quoted? v for-cify? datum-intern?))])))
;; Construct an expression to be lifted
@ -155,8 +153,10 @@
(cond
[(and (not for-cify?)
(large-quoted? q))
(add-lifted `(fasl->s-exp/intern
',(s-exp->fasl q)))]
;; a `to-fasl` struct is recognized like
;; paths and `path-for-srcloc`:
(define id (add-lifted (to-fasl (box q) #f)))
`(force-unfasl ,id)]
[else
(let make-construct ([q q])
(define lifted-constants (if (or (string? q) (bytes? q))

7
racket/src/schemify/to-fasl.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(provide (struct-out to-fasl))
(struct to-fasl (vb ; box containing byte string as marhsaled or other as unmarshaled
wrt) ; directory for unmarshaling
#:mutable)