repairs for change for machine-independent bytecode
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
parent
df8501d8f0
commit
6a35d64e95
|
|
@ -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
366
racket/collects/racket/private/c.rkt
Normal 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))))]))])))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
linklet-bigger-than?
|
||||
make-path->compiled-path
|
||||
compiled-path->path
|
||||
force-unfasl
|
||||
prim-knowns
|
||||
known-procedure
|
||||
known-procedure/pure
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
|
|
|||
|
|
@ -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
7
racket/src/schemify/to-fasl.rkt
Normal 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)
|
||||
Loading…
Reference in New Issue
Block a user