zo-marshal single out-anything function and zo-parse debugging
This commit is contained in:
Blake Johnson
Jay McCarthy
parent
f27fe3d5c9
commit
37f07cb68b
|
|
@ -8,9 +8,7 @@
|
||||||
racket/local
|
racket/local
|
||||||
racket/list
|
racket/list
|
||||||
racket/dict
|
racket/dict
|
||||||
racket/function
|
racket/function)
|
||||||
racket/pretty
|
|
||||||
racket/path)
|
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[zo-marshal (compilation-top? . -> . bytes?)]
|
[zo-marshal (compilation-top? . -> . bytes?)]
|
||||||
|
|
@ -24,8 +22,8 @@
|
||||||
(define (zo-marshal-to top outp)
|
(define (zo-marshal-to top outp)
|
||||||
(match top
|
(match top
|
||||||
[(struct compilation-top (max-let-depth prefix form))
|
[(struct compilation-top (max-let-depth prefix form))
|
||||||
(define shared (make-hasheq))
|
(define shared (make-hash))
|
||||||
(define wrapped (make-hasheq))
|
(define wrapped (make-hash))
|
||||||
(define (shared-obj-pos v)
|
(define (shared-obj-pos v)
|
||||||
(hash-ref shared v #f))
|
(hash-ref shared v #f))
|
||||||
(define (share! v)
|
(define (share! v)
|
||||||
|
|
@ -34,13 +32,15 @@
|
||||||
(list* max-let-depth prefix (protect-quote form)))
|
(list* max-let-depth prefix (protect-quote form)))
|
||||||
|
|
||||||
; Compute what objects are in ct multiple times (by equal?)
|
; Compute what objects are in ct multiple times (by equal?)
|
||||||
(local [(define encountered (make-hasheq))
|
(local [(define encountered (make-hash))
|
||||||
(define (encountered? v)
|
(define (encountered? v)
|
||||||
(hash-ref encountered v #f))
|
(hash-ref encountered v #f))
|
||||||
(define (encounter! v)
|
(define (encounter! v)
|
||||||
(hash-set! encountered v #t))
|
(hash-set! encountered v #t))
|
||||||
(define (visit! v)
|
(define (visit! v)
|
||||||
(cond
|
(cond
|
||||||
|
[(not (shareable? v))
|
||||||
|
#t]
|
||||||
[(shared-obj-pos v)
|
[(shared-obj-pos v)
|
||||||
#f]
|
#f]
|
||||||
[(encountered? v)
|
[(encountered? v)
|
||||||
|
|
@ -86,7 +86,7 @@
|
||||||
; Compute where we ended
|
; Compute where we ended
|
||||||
(define post-shared (file-position outp))
|
(define post-shared (file-position outp))
|
||||||
; Write the entire ctop
|
; Write the entire ctop
|
||||||
(out-data ct
|
(out-anything ct
|
||||||
(make-out outp shared-obj-pos wrapped))
|
(make-out outp shared-obj-pos wrapped))
|
||||||
(values offsets post-shared (file-position outp)))
|
(values offsets post-shared (file-position outp)))
|
||||||
|
|
||||||
|
|
@ -277,190 +277,6 @@
|
||||||
(define-struct case-seq (name lams))
|
(define-struct case-seq (name lams))
|
||||||
(define-struct (seq0 seq) ())
|
(define-struct (seq0 seq) ())
|
||||||
|
|
||||||
(define-struct out (s shared-index encoded-wraps))
|
|
||||||
(define (out-shared v out k)
|
|
||||||
(let ([v ((out-shared-index out) v)])
|
|
||||||
(if v
|
|
||||||
(begin
|
|
||||||
(out-byte CPT_SYMREF out)
|
|
||||||
(out-number v out))
|
|
||||||
(k))))
|
|
||||||
(define (display-byte b)
|
|
||||||
(if (b . <= . #xf)
|
|
||||||
(printf "0~x" b)
|
|
||||||
(printf "~x" b)))
|
|
||||||
|
|
||||||
(define (out-byte v out)
|
|
||||||
(write-byte v (out-s out)))
|
|
||||||
|
|
||||||
(define (out-bytes b out)
|
|
||||||
(write-bytes b (out-s out)))
|
|
||||||
|
|
||||||
(define (out-number n out)
|
|
||||||
(cond
|
|
||||||
[(n . < . 0)
|
|
||||||
(if (n . > . -32)
|
|
||||||
(out-byte (bitwise-ior #xC0 (- n)) out)
|
|
||||||
(begin
|
|
||||||
(out-byte #xE0 out)
|
|
||||||
(out-bytes (int->bytes (- n)) out)))]
|
|
||||||
[(n . < . 128)
|
|
||||||
(out-byte n out)]
|
|
||||||
[(n . < . #x4000)
|
|
||||||
(out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out)
|
|
||||||
(out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)]
|
|
||||||
[else
|
|
||||||
(out-byte #xF0 out)
|
|
||||||
(out-bytes (int->bytes n) out)]))
|
|
||||||
|
|
||||||
(define (out-syntax key val out)
|
|
||||||
(out-marshaled syntax-type-num (list* key val) out))
|
|
||||||
|
|
||||||
(define (out-marshaled type-num val out)
|
|
||||||
(if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START))
|
|
||||||
(out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out)
|
|
||||||
(begin
|
|
||||||
(out-byte CPT_MARSHALLED out)
|
|
||||||
(out-number type-num out)))
|
|
||||||
(out-data val out))
|
|
||||||
|
|
||||||
(define (out-anything v out)
|
|
||||||
(cond
|
|
||||||
[(module-variable? v)
|
|
||||||
(out-toplevel v out)]
|
|
||||||
[(closure? v)
|
|
||||||
(out-expr v out)]
|
|
||||||
[else
|
|
||||||
(out-data v out)]))
|
|
||||||
|
|
||||||
(define (out-prefix a-prefix out)
|
|
||||||
(match a-prefix
|
|
||||||
[(struct prefix (num-lifts toplevels stxs))
|
|
||||||
(out-marshaled
|
|
||||||
prefix-type-num
|
|
||||||
(cons num-lifts
|
|
||||||
(cons (list->vector toplevels)
|
|
||||||
(list->vector stxs)))
|
|
||||||
out)]))
|
|
||||||
|
|
||||||
(define (out-free-id-info a-free-id-info out)
|
|
||||||
(match a-free-id-info
|
|
||||||
[(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?))
|
|
||||||
(out-marshaled
|
|
||||||
free-id-info-type-num
|
|
||||||
(vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?)
|
|
||||||
out)]))
|
|
||||||
|
|
||||||
(define-struct module-decl (content))
|
|
||||||
|
|
||||||
(define (out-module mod-form out)
|
|
||||||
(match mod-form
|
|
||||||
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported
|
|
||||||
max-let-depth dummy lang-info internal-context))
|
|
||||||
(out-syntax MODULE_EXPD
|
|
||||||
(let* ([lookup-req (lambda (phase)
|
|
||||||
(let ([a (assq phase requires)])
|
|
||||||
(if a
|
|
||||||
(cdr a)
|
|
||||||
null)))]
|
|
||||||
[other-requires (filter (lambda (l)
|
|
||||||
(not (memq (car l) '(#f -1 0 1))))
|
|
||||||
requires)]
|
|
||||||
[extract-protects
|
|
||||||
(lambda (phase)
|
|
||||||
(let ([a (assq phase provides)])
|
|
||||||
(and a
|
|
||||||
(let ([p (map provided-protected? (append (cadr a)
|
|
||||||
(caddr a)))])
|
|
||||||
(if (ormap values p)
|
|
||||||
(list->vector p)
|
|
||||||
#f)))))]
|
|
||||||
[list->vector/#f (lambda (default l)
|
|
||||||
(if (andmap (lambda (x) (equal? x default)) l)
|
|
||||||
#f
|
|
||||||
(list->vector l)))]
|
|
||||||
[l
|
|
||||||
(let loop ([l other-requires])
|
|
||||||
(match l
|
|
||||||
[(list)
|
|
||||||
empty]
|
|
||||||
[(list-rest (cons phase reqs) rst)
|
|
||||||
(list* phase reqs (loop rst))]))]
|
|
||||||
[l (cons (length other-requires) l)]
|
|
||||||
[l (cons (lookup-req #f) l)] ; dt-requires
|
|
||||||
[l (cons (lookup-req -1) l)] ; tt-requires
|
|
||||||
[l (cons (lookup-req 1) l)] ; et-requires
|
|
||||||
[l (cons (lookup-req 0) l)] ; requires
|
|
||||||
[l (cons (list->vector body) l)]
|
|
||||||
[l (cons (list->vector
|
|
||||||
(for/list ([i (in-list syntax-body)])
|
|
||||||
(define (maybe-one l) ;; a single symbol is ok
|
|
||||||
(if (and (pair? l) (null? (cdr l)))
|
|
||||||
(car l)
|
|
||||||
l))
|
|
||||||
(match i
|
|
||||||
[(struct def-syntaxes (ids rhs prefix max-let-depth))
|
|
||||||
(vector (maybe-one ids) rhs max-let-depth prefix #f)]
|
|
||||||
[(struct def-for-syntax (ids rhs prefix max-let-depth))
|
|
||||||
(vector (maybe-one ids) rhs max-let-depth prefix #t)])))
|
|
||||||
l)]
|
|
||||||
[l (append (apply
|
|
||||||
append
|
|
||||||
(map (lambda (l)
|
|
||||||
(let ([phase (car l)]
|
|
||||||
[all (append (cadr l) (caddr l))])
|
|
||||||
(list phase
|
|
||||||
(list->vector/#f #f (map provided-insp all))
|
|
||||||
(list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p)))
|
|
||||||
all))
|
|
||||||
(list->vector/#f #f (map (lambda (p)
|
|
||||||
(if (eq? (provided-nom-src p)
|
|
||||||
(provided-src p))
|
|
||||||
#f ; #f means "same as src"
|
|
||||||
(provided-nom-src p)))
|
|
||||||
all))
|
|
||||||
(list->vector (map provided-src-name all))
|
|
||||||
(list->vector (map provided-src all))
|
|
||||||
(list->vector (map provided-name all))
|
|
||||||
(length (cadr l))
|
|
||||||
(length all))))
|
|
||||||
provides))
|
|
||||||
l)]
|
|
||||||
[l (cons (length provides) l)] ; number of provide sets
|
|
||||||
[l (cons (extract-protects 0) l)] ; protects
|
|
||||||
[l (cons (extract-protects 1) l)] ; et protects
|
|
||||||
[l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides
|
|
||||||
[l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides
|
|
||||||
[l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides
|
|
||||||
[l (cons prefix l)]
|
|
||||||
[l (cons dummy l)]
|
|
||||||
[l (cons max-let-depth l)]
|
|
||||||
[l (cons internal-context l)] ; module->namespace syntax
|
|
||||||
[l (list* #f #f l)] ; obsolete `functional?' info
|
|
||||||
[l (cons lang-info l)] ; lang-info
|
|
||||||
[l (cons self-modidx l)]
|
|
||||||
[l (cons srcname l)]
|
|
||||||
[l (cons name l)])
|
|
||||||
(make-module-decl l))
|
|
||||||
out)]))
|
|
||||||
|
|
||||||
(define (out-toplevel tl out)
|
|
||||||
(match tl
|
|
||||||
[#f (out-data tl out)]
|
|
||||||
[(? symbol?) (out-data tl out)]
|
|
||||||
[(struct global-bucket (name))
|
|
||||||
(out-marshaled variable-type-num name out)]
|
|
||||||
[(struct module-variable (modidx sym pos phase))
|
|
||||||
(out-shared
|
|
||||||
tl
|
|
||||||
out
|
|
||||||
(lambda ()
|
|
||||||
(out-byte CPT_MODULE_VAR out)
|
|
||||||
(out-data modidx out)
|
|
||||||
(out-data sym out)
|
|
||||||
(unless (zero? phase)
|
|
||||||
(out-number -2 out))
|
|
||||||
(out-number pos out)))]))
|
|
||||||
|
|
||||||
(define (encode-module-bindings module-bindings)
|
(define (encode-module-bindings module-bindings)
|
||||||
(define encode-nominal-path
|
(define encode-nominal-path
|
||||||
|
|
@ -591,26 +407,112 @@
|
||||||
(vector p (encode-certs certs))
|
(vector p (encode-certs certs))
|
||||||
p))]))
|
p))]))
|
||||||
|
|
||||||
(define (lookup-encoded-wrapped w out)
|
(define-struct out (s shared-index encoded-wraps))
|
||||||
(hash-ref (out-encoded-wraps out) w
|
(define (out-shared v out k)
|
||||||
(lambda ()
|
(if (shareable? v)
|
||||||
(error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w))))
|
(let ([v ((out-shared-index out) v)])
|
||||||
|
(if v
|
||||||
|
(begin
|
||||||
|
(out-byte CPT_SYMREF out)
|
||||||
|
(out-number v out))
|
||||||
|
(k)))
|
||||||
|
(k)))
|
||||||
|
|
||||||
(define (out-wrapped w out)
|
(define (out-byte v out)
|
||||||
(out-data (lookup-encoded-wrapped w out) out))
|
(write-byte v (out-s out)))
|
||||||
|
|
||||||
(define (out-stx s out)
|
(define (out-bytes b out)
|
||||||
(out-shared s out
|
(write-bytes b (out-s out)))
|
||||||
(lambda ()
|
|
||||||
(match s
|
|
||||||
[(struct stx (encoded))
|
|
||||||
(out-byte CPT_STX out)
|
|
||||||
(out-wrapped encoded out)]))))
|
|
||||||
|
|
||||||
(define (out-form form out)
|
(define (out-number n out)
|
||||||
(match form
|
(cond
|
||||||
|
[(n . < . 0)
|
||||||
|
(if (n . > . -32)
|
||||||
|
(out-byte (bitwise-ior #xC0 (- n)) out)
|
||||||
|
(begin
|
||||||
|
(out-byte #xE0 out)
|
||||||
|
(out-bytes (int->bytes (- n)) out)))]
|
||||||
|
[(n . < . 128)
|
||||||
|
(out-byte n out)]
|
||||||
|
[(n . < . #x4000)
|
||||||
|
(out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out)
|
||||||
|
(out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)]
|
||||||
|
[else
|
||||||
|
(out-byte #xF0 out)
|
||||||
|
(out-bytes (int->bytes n) out)]))
|
||||||
|
|
||||||
|
(define (out-syntax key val out)
|
||||||
|
(out-marshaled syntax-type-num (list* key val) out))
|
||||||
|
|
||||||
|
(define (out-marshaled type-num val out)
|
||||||
|
(if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START))
|
||||||
|
(out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out)
|
||||||
|
(begin
|
||||||
|
(out-byte CPT_MARSHALLED out)
|
||||||
|
(out-number type-num out)))
|
||||||
|
(out-anything val out))
|
||||||
|
|
||||||
|
(define (or-pred? v . ps)
|
||||||
|
(ormap (lambda (?) (? v)) ps))
|
||||||
|
|
||||||
|
(define (shareable? v)
|
||||||
|
(not (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))
|
||||||
|
|
||||||
|
(define (maybe-same-as-fixnum? v)
|
||||||
|
(and (exact-integer? v)
|
||||||
|
(and (v . >= . -1073741824) (v . <= . 1073741823))))
|
||||||
|
|
||||||
|
(define (out-anything v out)
|
||||||
|
(out-shared
|
||||||
|
v out
|
||||||
|
(λ ()
|
||||||
|
(match v
|
||||||
|
[(? char?)
|
||||||
|
(out-byte CPT_CHAR out)
|
||||||
|
(out-number (char->integer v) out)]
|
||||||
|
[(? maybe-same-as-fixnum?) ;XXX not sure if it's okay to use fixnum? instead of exact range check
|
||||||
|
(if (and (v . >= . 0)
|
||||||
|
(v . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START)))
|
||||||
|
(out-byte (+ CPT_SMALL_NUMBER_START v) out)
|
||||||
|
(begin
|
||||||
|
(out-byte CPT_INT out)
|
||||||
|
(out-number v out)))]
|
||||||
|
[(list)
|
||||||
|
(out-byte CPT_NULL out)]
|
||||||
|
[#t
|
||||||
|
(out-byte CPT_TRUE out)]
|
||||||
|
[#f
|
||||||
|
(out-byte CPT_FALSE out)]
|
||||||
|
[(? void?)
|
||||||
|
(out-byte CPT_VOID out)]
|
||||||
|
[(struct module-variable (modidx sym pos phase))
|
||||||
|
(out-byte CPT_MODULE_VAR out)
|
||||||
|
(out-anything modidx out)
|
||||||
|
(out-anything sym out)
|
||||||
|
(unless (zero? phase)
|
||||||
|
(out-number -2 out))
|
||||||
|
(out-number pos out)]
|
||||||
|
[(struct indirect (val)) (out-anything val out)]
|
||||||
|
[(struct closure (lam gen-id))
|
||||||
|
(out-byte CPT_CLOSURE out)
|
||||||
|
(out-number ((out-shared-index out) v) out)
|
||||||
|
(out-anything lam out)]
|
||||||
|
[(struct prefix (num-lifts toplevels stxs))
|
||||||
|
(out-marshaled
|
||||||
|
prefix-type-num
|
||||||
|
(cons num-lifts
|
||||||
|
(cons (list->vector toplevels)
|
||||||
|
(list->vector stxs)))
|
||||||
|
out)]
|
||||||
|
[(struct global-bucket (name))
|
||||||
|
(out-marshaled variable-type-num name out)]
|
||||||
|
[(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?))
|
||||||
|
(out-marshaled
|
||||||
|
free-id-info-type-num
|
||||||
|
(vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?)
|
||||||
|
out)]
|
||||||
[(? mod?)
|
[(? mod?)
|
||||||
(out-module form out)]
|
(out-module v out)]
|
||||||
[(struct def-values (ids rhs))
|
[(struct def-values (ids rhs))
|
||||||
(out-syntax DEFINE_VALUES_EXPD
|
(out-syntax DEFINE_VALUES_EXPD
|
||||||
(list->vector (cons (protect-quote rhs) ids))
|
(list->vector (cons (protect-quote rhs) ids))
|
||||||
|
|
@ -640,11 +542,6 @@
|
||||||
[(struct req (reqs dummy))
|
[(struct req (reqs dummy))
|
||||||
(error "cannot handle top-level `require', yet")
|
(error "cannot handle top-level `require', yet")
|
||||||
(out-syntax REQUIRE_EXPD (cons dummy reqs) out)]
|
(out-syntax REQUIRE_EXPD (cons dummy reqs) out)]
|
||||||
[else
|
|
||||||
(out-expr form out)]))
|
|
||||||
|
|
||||||
(define (out-expr expr out)
|
|
||||||
(match expr
|
|
||||||
[(struct toplevel (depth pos const? ready?))
|
[(struct toplevel (depth pos const? ready?))
|
||||||
(out-marshaled toplevel-type-num
|
(out-marshaled toplevel-type-num
|
||||||
(cons
|
(cons
|
||||||
|
|
@ -691,16 +588,17 @@
|
||||||
0)))
|
0)))
|
||||||
out)))))]
|
out)))))]
|
||||||
[(? lam?)
|
[(? lam?)
|
||||||
(out-lam expr out)]
|
(out-lam v out)]
|
||||||
[(struct case-lam (name lams))
|
[(struct case-lam (name lams))
|
||||||
(let ([seq (make-case-seq name lams)])
|
(let ([seq (make-case-seq name lams)])
|
||||||
;; If all closures are empy, generate a case sequence directly
|
;; XXX: This seems like an optimization, which should probably happen somewhere else
|
||||||
|
;; If all closures are empty, generate a case sequence directly
|
||||||
(if (andmap (lambda (lam)
|
(if (andmap (lambda (lam)
|
||||||
(or (closure? lam)
|
(or (closure? lam)
|
||||||
(and (lam? lam)
|
(and (lam? lam)
|
||||||
(equal? (lam-closure-map lam) #()))))
|
(equal? (lam-closure-map lam) #()))))
|
||||||
lams)
|
lams)
|
||||||
(out-data seq out)
|
(out-anything seq out)
|
||||||
(out-syntax CASE_LAMBDA_EXPD
|
(out-syntax CASE_LAMBDA_EXPD
|
||||||
seq
|
seq
|
||||||
out)))]
|
out)))]
|
||||||
|
|
@ -715,8 +613,8 @@
|
||||||
[unused? CPT_LET_ONE_UNUSED]
|
[unused? CPT_LET_ONE_UNUSED]
|
||||||
[else CPT_LET_ONE])
|
[else CPT_LET_ONE])
|
||||||
out)
|
out)
|
||||||
(out-expr (protect-quote rhs) out)
|
(out-anything (protect-quote rhs) out)
|
||||||
(out-expr (protect-quote body) out)]
|
(out-anything (protect-quote body) out)]
|
||||||
[(struct let-void (count boxes? body))
|
[(struct let-void (count boxes? body))
|
||||||
(out-marshaled let-void-type-num
|
(out-marshaled let-void-type-num
|
||||||
(list*
|
(list*
|
||||||
|
|
@ -748,9 +646,9 @@
|
||||||
out)]
|
out)]
|
||||||
[(struct branch (test then else))
|
[(struct branch (test then else))
|
||||||
(out-byte CPT_BRANCH out)
|
(out-byte CPT_BRANCH out)
|
||||||
(out-expr (protect-quote test) out)
|
(out-anything (protect-quote test) out)
|
||||||
(out-expr (protect-quote then) out)
|
(out-anything (protect-quote then) out)
|
||||||
(out-expr (protect-quote else) out)]
|
(out-anything (protect-quote else) out)]
|
||||||
[(struct application (rator rands))
|
[(struct application (rator rands))
|
||||||
(let ([len (length rands)])
|
(let ([len (length rands)])
|
||||||
(if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START))
|
(if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START))
|
||||||
|
|
@ -758,15 +656,13 @@
|
||||||
(begin
|
(begin
|
||||||
(out-byte CPT_APPLICATION out)
|
(out-byte CPT_APPLICATION out)
|
||||||
(out-number len out)))
|
(out-number len out)))
|
||||||
(for-each (lambda (e) (out-expr (protect-quote e) out))
|
(for-each (lambda (e) (out-anything (protect-quote e) out))
|
||||||
(cons rator rands)))]
|
(cons rator rands)))]
|
||||||
[(struct apply-values (proc args-expr))
|
[(struct apply-values (proc args-expr))
|
||||||
(out-syntax APPVALS_EXPD
|
(out-syntax APPVALS_EXPD
|
||||||
(cons (protect-quote proc)
|
(cons (protect-quote proc)
|
||||||
(protect-quote args-expr))
|
(protect-quote args-expr))
|
||||||
out)]
|
out)]
|
||||||
[(struct seq (exprs))
|
|
||||||
(out-form expr out)]
|
|
||||||
[(struct beg0 (exprs))
|
[(struct beg0 (exprs))
|
||||||
(out-syntax BEGIN0_EXPD
|
(out-syntax BEGIN0_EXPD
|
||||||
(make-seq0 exprs)
|
(make-seq0 exprs)
|
||||||
|
|
@ -778,27 +674,254 @@
|
||||||
(protect-quote val)
|
(protect-quote val)
|
||||||
(protect-quote body))
|
(protect-quote body))
|
||||||
out)]
|
out)]
|
||||||
[(struct closure (lam gen-id))
|
|
||||||
(out-lam expr out)]
|
|
||||||
[(struct indirect (val))
|
|
||||||
(out-expr val out)]
|
|
||||||
[(struct varref (expr))
|
[(struct varref (expr))
|
||||||
(out-syntax REF_EXPD
|
(out-syntax REF_EXPD
|
||||||
expr
|
expr
|
||||||
out)]
|
out)]
|
||||||
[else (out-value expr out)]))
|
[(protected-symref v)
|
||||||
|
(out-anything ((out-shared-index out) v) out)]
|
||||||
|
[(and (? symbol?) (not (? symbol-interned?)))
|
||||||
|
(out-as-bytes v
|
||||||
|
#:before-length (if (symbol-unreadable? v) 0 1)
|
||||||
|
(compose string->bytes/utf-8 symbol->string)
|
||||||
|
CPT_WEIRD_SYMBOL
|
||||||
|
#f
|
||||||
|
out)]
|
||||||
|
[(? symbol?)
|
||||||
|
(define bs (string->bytes/utf-8 (symbol->string v)))
|
||||||
|
(define len (bytes-length bs))
|
||||||
|
(if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START))
|
||||||
|
(out-byte (+ CPT_SMALL_SYMBOL_START len) out)
|
||||||
|
(begin (out-byte CPT_SYMBOL out)
|
||||||
|
(out-number len out)))
|
||||||
|
(out-bytes bs out)]
|
||||||
|
[(? keyword?)
|
||||||
|
(out-as-bytes v
|
||||||
|
(compose string->bytes/utf-8 keyword->string)
|
||||||
|
CPT_KEYWORD
|
||||||
|
#f
|
||||||
|
out)]
|
||||||
|
[(? string?)
|
||||||
|
(out-as-bytes v
|
||||||
|
string->bytes/utf-8
|
||||||
|
CPT_CHAR_STRING
|
||||||
|
(string-length v)
|
||||||
|
out)]
|
||||||
|
[(? bytes?)
|
||||||
|
(out-as-bytes v
|
||||||
|
values
|
||||||
|
CPT_BYTE_STRING
|
||||||
|
#f
|
||||||
|
out)]
|
||||||
|
[(? box?)
|
||||||
|
(out-byte CPT_BOX out)
|
||||||
|
(out-anything (unbox v) out)]
|
||||||
|
[(? pair?)
|
||||||
|
(define (list-length-before-cycle/improper-end l)
|
||||||
|
(let loop ([len 1] [l (cdr l)])
|
||||||
|
(cond
|
||||||
|
[((out-shared-index out) l)
|
||||||
|
(values len #f)]
|
||||||
|
[(null? l)
|
||||||
|
(values len #t)]
|
||||||
|
[(pair? l)
|
||||||
|
(loop (add1 len) (cdr l))]
|
||||||
|
[else
|
||||||
|
(values len #f)])))
|
||||||
|
(define-values (len proper?) (list-length-before-cycle/improper-end v))
|
||||||
|
(define (print-contents-as-proper)
|
||||||
|
(for ([e (in-list v)])
|
||||||
|
(out-anything e out)))
|
||||||
|
(define (print-contents-as-improper)
|
||||||
|
(let loop ([l v] [i len])
|
||||||
|
(cond
|
||||||
|
[(zero? i)
|
||||||
|
(out-anything l out)]
|
||||||
|
[else
|
||||||
|
(out-anything (car l) out)
|
||||||
|
(loop (cdr l) (sub1 i))])))
|
||||||
|
(if proper?
|
||||||
|
(if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START))
|
||||||
|
(begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out)
|
||||||
|
(print-contents-as-proper))
|
||||||
|
(begin (out-byte CPT_LIST out)
|
||||||
|
(out-number len out)
|
||||||
|
(print-contents-as-proper)
|
||||||
|
(out-anything null out)))
|
||||||
|
(if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START))
|
||||||
|
; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR
|
||||||
|
(begin (out-byte (+ CPT_SMALL_LIST_START len) out)
|
||||||
|
(print-contents-as-improper))
|
||||||
|
(begin (out-byte CPT_LIST out)
|
||||||
|
(out-number len out)
|
||||||
|
(print-contents-as-improper))))]
|
||||||
|
[(? vector?)
|
||||||
|
(out-byte CPT_VECTOR out)
|
||||||
|
(out-number (vector-length v) out)
|
||||||
|
(for ([v (in-vector v)])
|
||||||
|
(out-anything v out))]
|
||||||
|
[(? hash?)
|
||||||
|
(out-byte CPT_HASH_TABLE out)
|
||||||
|
(out-number (cond
|
||||||
|
[(hash-eqv? v) 2]
|
||||||
|
[(hash-eq? v) 0]
|
||||||
|
[else 1])
|
||||||
|
out)
|
||||||
|
(out-number (hash-count v) out)
|
||||||
|
(for ([(k v) (in-hash v)])
|
||||||
|
(out-anything k out)
|
||||||
|
(out-anything v out))]
|
||||||
|
[(svector vec)
|
||||||
|
(let* ([len (vector-length vec)])
|
||||||
|
(if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START))
|
||||||
|
(out-byte (+ CPT_SMALL_SVECTOR_START len) out)
|
||||||
|
(begin (out-byte CPT_SVECTOR out)
|
||||||
|
(out-number len out)))
|
||||||
|
(for ([n (in-range (sub1 len) -1 -1)])
|
||||||
|
(out-number (vector-ref vec n) out)))]
|
||||||
|
[(? module-path-index?)
|
||||||
|
(out-byte CPT_MODULE_INDEX out)
|
||||||
|
(let-values ([(name base) (module-path-index-split v)])
|
||||||
|
(out-anything name out)
|
||||||
|
(out-anything base out))]
|
||||||
|
[(module-decl content)
|
||||||
|
(out-marshaled module-type-num
|
||||||
|
content
|
||||||
|
out)]
|
||||||
|
[(stx encoded)
|
||||||
|
(out-byte CPT_STX out)
|
||||||
|
(out-anything encoded out)]
|
||||||
|
[(? wrapped?)
|
||||||
|
(out-anything (lookup-encoded-wrapped v out) out)]
|
||||||
|
[(? prefab-struct-key)
|
||||||
|
(define pre-v (struct->vector v))
|
||||||
|
(vector-set! pre-v 0 (prefab-struct-key v))
|
||||||
|
(out-byte CPT_PREFAB out)
|
||||||
|
(out-anything pre-v out)]
|
||||||
|
[else
|
||||||
|
(out-byte CPT_QUOTE out)
|
||||||
|
(if (quoted? v)
|
||||||
|
(out-anything (quoted-v v) out)
|
||||||
|
(let ([s (open-output-bytes)])
|
||||||
|
(parameterize ([pretty-print-size-hook
|
||||||
|
(lambda (v mode port)
|
||||||
|
(and (path? v)
|
||||||
|
(let ([v (make-relative v)])
|
||||||
|
(+ 2 (let ([p (open-output-bytes)])
|
||||||
|
(write (path->bytes v) p)
|
||||||
|
(bytes-length (get-output-bytes p)))))))]
|
||||||
|
[pretty-print-print-hook
|
||||||
|
(lambda (v mode port)
|
||||||
|
(display "#^" port)
|
||||||
|
(write (path->bytes (make-relative v)) port))])
|
||||||
|
(pretty-write expr s))
|
||||||
|
(out-byte CPT_ESCAPE out)
|
||||||
|
(let ([bstr (get-output-bytes s)])
|
||||||
|
(out-number (bytes-length bstr) out)
|
||||||
|
(out-bytes bstr out))))]))))
|
||||||
|
|
||||||
|
(define-struct module-decl (content))
|
||||||
|
|
||||||
|
(define (out-module mod-form out)
|
||||||
|
(match mod-form
|
||||||
|
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported
|
||||||
|
max-let-depth dummy lang-info internal-context))
|
||||||
|
(out-syntax MODULE_EXPD
|
||||||
|
(let* ([lookup-req (lambda (phase)
|
||||||
|
(let ([a (assq phase requires)])
|
||||||
|
(if a
|
||||||
|
(cdr a)
|
||||||
|
null)))]
|
||||||
|
[other-requires (filter (lambda (l)
|
||||||
|
(not (memq (car l) '(#f -1 0 1))))
|
||||||
|
requires)]
|
||||||
|
[extract-protects
|
||||||
|
(lambda (phase)
|
||||||
|
(let ([a (assq phase provides)])
|
||||||
|
(and a
|
||||||
|
(let ([p (map provided-protected? (append (cadr a)
|
||||||
|
(caddr a)))])
|
||||||
|
(if (ormap values p)
|
||||||
|
(list->vector p)
|
||||||
|
#f)))))]
|
||||||
|
[list->vector/#f (lambda (default l)
|
||||||
|
(if (andmap (lambda (x) (equal? x default)) l)
|
||||||
|
#f
|
||||||
|
(list->vector l)))]
|
||||||
|
[l
|
||||||
|
(let loop ([l other-requires])
|
||||||
|
(match l
|
||||||
|
[(list)
|
||||||
|
empty]
|
||||||
|
[(list-rest (cons phase reqs) rst)
|
||||||
|
(list* phase reqs (loop rst))]))]
|
||||||
|
[l (cons (length other-requires) l)]
|
||||||
|
[l (cons (lookup-req #f) l)] ; dt-requires
|
||||||
|
[l (cons (lookup-req -1) l)] ; tt-requires
|
||||||
|
[l (cons (lookup-req 1) l)] ; et-requires
|
||||||
|
[l (cons (lookup-req 0) l)] ; requires
|
||||||
|
[l (cons (list->vector body) l)]
|
||||||
|
[l (cons (list->vector
|
||||||
|
(for/list ([i (in-list syntax-body)])
|
||||||
|
(define (maybe-one l) ;; a single symbol is ok
|
||||||
|
(if (and (pair? l) (null? (cdr l)))
|
||||||
|
(car l)
|
||||||
|
l))
|
||||||
|
(match i
|
||||||
|
[(struct def-syntaxes (ids rhs prefix max-let-depth))
|
||||||
|
(vector (maybe-one ids) rhs max-let-depth prefix #f)]
|
||||||
|
[(struct def-for-syntax (ids rhs prefix max-let-depth))
|
||||||
|
(vector (maybe-one ids) rhs max-let-depth prefix #t)])))
|
||||||
|
l)]
|
||||||
|
[l (append (apply
|
||||||
|
append
|
||||||
|
(map (lambda (l)
|
||||||
|
(let ([phase (car l)]
|
||||||
|
[all (append (cadr l) (caddr l))])
|
||||||
|
(list phase
|
||||||
|
(list->vector/#f #f (map provided-insp all))
|
||||||
|
(list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p)))
|
||||||
|
all))
|
||||||
|
(list->vector/#f #f (map (lambda (p)
|
||||||
|
(if (eq? (provided-nom-src p)
|
||||||
|
(provided-src p))
|
||||||
|
#f ; #f means "same as src"
|
||||||
|
(provided-nom-src p)))
|
||||||
|
all))
|
||||||
|
(list->vector (map provided-src-name all))
|
||||||
|
(list->vector (map provided-src all))
|
||||||
|
(list->vector (map provided-name all))
|
||||||
|
(length (cadr l))
|
||||||
|
(length all))))
|
||||||
|
provides))
|
||||||
|
l)]
|
||||||
|
[l (cons (length provides) l)] ; number of provide sets
|
||||||
|
[l (cons (extract-protects 0) l)] ; protects
|
||||||
|
[l (cons (extract-protects 1) l)] ; et protects
|
||||||
|
[l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides
|
||||||
|
[l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides
|
||||||
|
[l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides
|
||||||
|
[l (cons prefix l)]
|
||||||
|
[l (cons dummy l)]
|
||||||
|
[l (cons max-let-depth l)]
|
||||||
|
[l (cons internal-context l)] ; module->namespace syntax
|
||||||
|
[l (list* #f #f l)] ; obsolete `functional?' info
|
||||||
|
[l (cons lang-info l)] ; lang-info
|
||||||
|
[l (cons self-modidx l)]
|
||||||
|
[l (cons srcname l)]
|
||||||
|
[l (cons name l)])
|
||||||
|
(make-module-decl l))
|
||||||
|
out)]))
|
||||||
|
|
||||||
|
|
||||||
|
(define (lookup-encoded-wrapped w out)
|
||||||
|
(hash-ref (out-encoded-wraps out) w
|
||||||
|
(lambda ()
|
||||||
|
(error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w))))
|
||||||
|
|
||||||
|
|
||||||
(define (out-lam expr out)
|
(define (out-lam expr out)
|
||||||
(match expr
|
(match expr
|
||||||
[(struct indirect (val)) (out-lam val out)]
|
|
||||||
[(struct closure (lam gen-id))
|
|
||||||
(out-shared
|
|
||||||
expr
|
|
||||||
out
|
|
||||||
(lambda ()
|
|
||||||
(out-byte CPT_CLOSURE out)
|
|
||||||
(out-number ((out-shared-index out) expr) out)
|
|
||||||
(out-lam lam out)))]
|
|
||||||
[(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))
|
[(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))
|
||||||
(let* ([l (protect-quote body)]
|
(let* ([l (protect-quote body)]
|
||||||
[any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types)
|
[any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types)
|
||||||
|
|
@ -845,207 +968,13 @@
|
||||||
out))]))
|
out))]))
|
||||||
|
|
||||||
(define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f])
|
(define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f])
|
||||||
(out-shared expr out (lambda ()
|
(define s (->bytes expr))
|
||||||
(let ([s (->bytes expr)])
|
|
||||||
(out-byte CPT out)
|
(out-byte CPT out)
|
||||||
(when before-length
|
(when before-length
|
||||||
(out-number before-length out))
|
(out-number before-length out))
|
||||||
(out-number (bytes-length s) out)
|
(out-number (bytes-length s) out)
|
||||||
(when len2 (out-number len2 out))
|
(when len2 (out-number len2 out))
|
||||||
(out-bytes s out)))))
|
(out-bytes s out))
|
||||||
|
|
||||||
(define (out-data expr out)
|
|
||||||
(cond
|
|
||||||
[(prefix? expr) (out-prefix expr out)]
|
|
||||||
[(global-bucket? expr) (out-toplevel expr out)]
|
|
||||||
[(module-variable? expr) (out-toplevel expr out)]
|
|
||||||
[(free-id-info? expr) (out-free-id-info expr out)]
|
|
||||||
[else (out-form expr out)]))
|
|
||||||
|
|
||||||
(define (out-value expr out)
|
|
||||||
(cond
|
|
||||||
[(protected-symref? expr)
|
|
||||||
(let* ([val (protected-symref-val expr)]
|
|
||||||
[val-ref ((out-shared-index out) val)])
|
|
||||||
(out-value val-ref out))]
|
|
||||||
[(and (symbol? expr) (not (symbol-interned? expr)))
|
|
||||||
(out-as-bytes expr
|
|
||||||
#:before-length (if (symbol-unreadable? expr) 0 1)
|
|
||||||
(compose string->bytes/utf-8 symbol->string)
|
|
||||||
CPT_WEIRD_SYMBOL
|
|
||||||
#f
|
|
||||||
out)]
|
|
||||||
[(symbol? expr)
|
|
||||||
(out-shared expr out
|
|
||||||
(lambda ()
|
|
||||||
(define bs (string->bytes/utf-8 (symbol->string expr)))
|
|
||||||
(define len (bytes-length bs))
|
|
||||||
(if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START))
|
|
||||||
(out-byte (+ CPT_SMALL_SYMBOL_START len) out)
|
|
||||||
(begin (out-byte CPT_SYMBOL out)
|
|
||||||
(out-number len out)))
|
|
||||||
(out-bytes bs out)))]
|
|
||||||
[(keyword? expr)
|
|
||||||
(out-as-bytes expr
|
|
||||||
(compose string->bytes/utf-8 keyword->string)
|
|
||||||
CPT_KEYWORD
|
|
||||||
#f
|
|
||||||
out)]
|
|
||||||
[(string? expr)
|
|
||||||
(out-as-bytes expr
|
|
||||||
string->bytes/utf-8
|
|
||||||
CPT_CHAR_STRING
|
|
||||||
(string-length expr)
|
|
||||||
out)]
|
|
||||||
[(bytes? expr)
|
|
||||||
(out-as-bytes expr
|
|
||||||
values
|
|
||||||
CPT_BYTE_STRING
|
|
||||||
#f
|
|
||||||
out)]
|
|
||||||
#;
|
|
||||||
[(path? expr)
|
|
||||||
(out-as-bytes expr
|
|
||||||
path->bytes
|
|
||||||
CPT_PATH
|
|
||||||
#f
|
|
||||||
out)]
|
|
||||||
[(char? expr)
|
|
||||||
(out-byte CPT_CHAR out)
|
|
||||||
(out-number (char->integer expr) out)]
|
|
||||||
[(and (exact-integer? expr)
|
|
||||||
(and (expr . >= . -1073741824) (expr . <= . 1073741823)))
|
|
||||||
(if (and (expr . >= . 0)
|
|
||||||
(expr . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START)))
|
|
||||||
(out-byte (+ CPT_SMALL_NUMBER_START expr) out)
|
|
||||||
(begin
|
|
||||||
(out-byte CPT_INT out)
|
|
||||||
(out-number expr out)))]
|
|
||||||
[(null? expr)
|
|
||||||
(out-byte CPT_NULL out)]
|
|
||||||
[(eq? expr #t)
|
|
||||||
(out-byte CPT_TRUE out)]
|
|
||||||
[(eq? expr #f)
|
|
||||||
(out-byte CPT_FALSE out)]
|
|
||||||
[(void? expr)
|
|
||||||
(out-byte CPT_VOID out)]
|
|
||||||
[(box? expr)
|
|
||||||
(out-byte CPT_BOX out)
|
|
||||||
(out-data (unbox expr) out)]
|
|
||||||
[(pair? expr)
|
|
||||||
(local [(define seen? (make-hasheq)) ; XXX Maybe this should be global?
|
|
||||||
(define (list-length-before-cycle/improper-end l)
|
|
||||||
(if (hash-has-key? seen? l)
|
|
||||||
(begin (values 0 #f))
|
|
||||||
(begin (hash-set! seen? l #t)
|
|
||||||
(cond
|
|
||||||
[(null? l)
|
|
||||||
(values 0 #t)]
|
|
||||||
[(pair? l)
|
|
||||||
(let-values ([(len proper?)
|
|
||||||
(list-length-before-cycle/improper-end (cdr l))])
|
|
||||||
(values (add1 len) proper?))]
|
|
||||||
[else
|
|
||||||
(values 0 #f)]))))
|
|
||||||
(define-values (len proper?) (list-length-before-cycle/improper-end expr))
|
|
||||||
(define (print-contents-as-proper)
|
|
||||||
(for ([e (in-list expr)])
|
|
||||||
(out-data e out)))
|
|
||||||
(define (print-contents-as-improper)
|
|
||||||
(let loop ([l expr] [i len])
|
|
||||||
(cond
|
|
||||||
[(zero? i)
|
|
||||||
(out-data l out)]
|
|
||||||
[else
|
|
||||||
(out-data (car l) out)
|
|
||||||
(loop (cdr l) (sub1 i))])))]
|
|
||||||
(if proper?
|
|
||||||
(if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START))
|
|
||||||
(begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out)
|
|
||||||
(print-contents-as-proper))
|
|
||||||
(begin (out-byte CPT_LIST out)
|
|
||||||
(out-number len out)
|
|
||||||
(print-contents-as-proper)
|
|
||||||
(out-data null out)))
|
|
||||||
(if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START))
|
|
||||||
; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR
|
|
||||||
(begin (out-byte (+ CPT_SMALL_LIST_START len) out)
|
|
||||||
(print-contents-as-improper))
|
|
||||||
(begin (out-byte CPT_LIST out)
|
|
||||||
(out-number len out)
|
|
||||||
(print-contents-as-improper)))))]
|
|
||||||
[(vector? expr)
|
|
||||||
(out-byte CPT_VECTOR out)
|
|
||||||
(out-number (vector-length expr) out)
|
|
||||||
(for ([v (in-vector expr)])
|
|
||||||
(out-data v out))]
|
|
||||||
[(hash? expr)
|
|
||||||
(out-shared expr out
|
|
||||||
(lambda ()
|
|
||||||
(out-byte CPT_HASH_TABLE out)
|
|
||||||
(out-number (cond
|
|
||||||
[(hash-eqv? expr) 2]
|
|
||||||
[(hash-eq? expr) 0]
|
|
||||||
[else 1])
|
|
||||||
out)
|
|
||||||
(out-number (hash-count expr) out)
|
|
||||||
(for ([(k v) (in-hash expr)])
|
|
||||||
(out-data k out)
|
|
||||||
(out-data v out))))]
|
|
||||||
[(svector? expr)
|
|
||||||
(let* ([vec (svector-vec expr)]
|
|
||||||
[len (vector-length vec)])
|
|
||||||
(if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START))
|
|
||||||
(out-byte (+ CPT_SMALL_SVECTOR_START len) out)
|
|
||||||
(begin (out-byte CPT_SVECTOR out)
|
|
||||||
(out-number len out)))
|
|
||||||
(for ([n (in-range (sub1 len) -1 -1)])
|
|
||||||
(out-number (vector-ref vec n) out)))]
|
|
||||||
[(module-path-index? expr)
|
|
||||||
(out-shared expr out
|
|
||||||
(lambda ()
|
|
||||||
(out-byte CPT_MODULE_INDEX out)
|
|
||||||
(let-values ([(name base) (module-path-index-split expr)])
|
|
||||||
(out-data name out)
|
|
||||||
(out-data base out))))]
|
|
||||||
[(module-decl? expr)
|
|
||||||
(out-marshaled module-type-num
|
|
||||||
(module-decl-content expr)
|
|
||||||
out)]
|
|
||||||
[(stx? expr)
|
|
||||||
(out-stx expr out)]
|
|
||||||
[(wrapped? expr)
|
|
||||||
(out-wrapped expr out)]
|
|
||||||
[(prefab-struct-key expr)
|
|
||||||
=> (lambda (key)
|
|
||||||
(define pre-v (struct->vector expr))
|
|
||||||
(vector-set! pre-v 0 key)
|
|
||||||
(out-byte CPT_PREFAB out)
|
|
||||||
(out-data pre-v out))]
|
|
||||||
[else
|
|
||||||
(out-byte CPT_QUOTE out)
|
|
||||||
(if (quoted? expr)
|
|
||||||
(out-data (quoted-v expr) out)
|
|
||||||
(let ([s (open-output-bytes)])
|
|
||||||
;; print `expr' to a string, but print paths
|
|
||||||
;; in a special way
|
|
||||||
(parameterize ([pretty-print-size-hook
|
|
||||||
(lambda (v mode port)
|
|
||||||
(and (path? v)
|
|
||||||
(let ([v (make-relative v)])
|
|
||||||
(+ 2 (let ([p (open-output-bytes)])
|
|
||||||
(write (path->bytes v) p)
|
|
||||||
(bytes-length (get-output-bytes p)))))))]
|
|
||||||
[pretty-print-print-hook
|
|
||||||
(lambda (v mode port)
|
|
||||||
(display "#^" port)
|
|
||||||
(write (path->bytes (make-relative v)) port))])
|
|
||||||
(pretty-write expr s))
|
|
||||||
(out-byte CPT_ESCAPE out)
|
|
||||||
(let ([bstr (get-output-bytes s)])
|
|
||||||
(out-number (bytes-length bstr) out)
|
|
||||||
(out-bytes bstr out))))]))
|
|
||||||
|
|
||||||
|
|
||||||
(define-struct quoted (v))
|
(define-struct quoted (v))
|
||||||
|
|
||||||
|
|
@ -1057,11 +986,5 @@
|
||||||
|
|
||||||
(define-struct svector (vec))
|
(define-struct svector (vec))
|
||||||
|
|
||||||
(define (make-relative v)
|
|
||||||
(let ([r (current-write-relative-directory)])
|
|
||||||
(if r
|
|
||||||
(find-relative-path r v)
|
|
||||||
v)))
|
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,11 @@
|
||||||
#lang scheme/base
|
#lang scheme/base
|
||||||
(require mzlib/etc
|
(require mzlib/etc
|
||||||
|
racket/function
|
||||||
scheme/match
|
scheme/match
|
||||||
scheme/list
|
scheme/list
|
||||||
unstable/struct
|
unstable/struct
|
||||||
compiler/zo-structs)
|
compiler/zo-structs
|
||||||
|
racket/dict)
|
||||||
|
|
||||||
(provide zo-parse)
|
(provide zo-parse)
|
||||||
(provide (all-from-out compiler/zo-structs))
|
(provide (all-from-out compiler/zo-structs))
|
||||||
|
|
@ -30,6 +32,8 @@
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
;; Bytecode unmarshalers for various forms
|
;; Bytecode unmarshalers for various forms
|
||||||
|
|
||||||
|
(define debug-symrefs #f)
|
||||||
|
|
||||||
(define (read-toplevel v)
|
(define (read-toplevel v)
|
||||||
(define SCHEME_TOPLEVEL_CONST #x01)
|
(define SCHEME_TOPLEVEL_CONST #x01)
|
||||||
(define SCHEME_TOPLEVEL_READY #x02)
|
(define SCHEME_TOPLEVEL_READY #x02)
|
||||||
|
|
@ -503,26 +507,31 @@
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
;; Syntax unmarshaling
|
;; Syntax unmarshaling
|
||||||
(define (decode-mark-map alist)
|
(define (make-memo) (make-weak-hash))
|
||||||
alist
|
(define (with-memo* mt arg thnk)
|
||||||
#;(let loop ([alist alist]
|
(hash-ref! mt arg thnk))
|
||||||
[ht (make-immutable-hasheq empty)])
|
(define-syntax-rule (with-memo mt arg body ...)
|
||||||
(match alist
|
(with-memo* mt arg (λ () body ...)))
|
||||||
[(list) ht]
|
|
||||||
[(list* (? number? key) (? module-path-index? val) alist)
|
|
||||||
(loop alist (hash-set ht key val))])))
|
|
||||||
|
|
||||||
|
(define (decode-mark-map alist)
|
||||||
|
alist)
|
||||||
|
|
||||||
|
(define marks-memo (make-memo))
|
||||||
(define (decode-marks cp ms)
|
(define (decode-marks cp ms)
|
||||||
|
(with-memo marks-memo ms
|
||||||
(match ms
|
(match ms
|
||||||
[#f #f]
|
[#f #f]
|
||||||
[(list* #f (? number? symref) alist)
|
[(list* #f (? number? symref) alist)
|
||||||
(make-certificate:ref
|
(make-certificate:ref
|
||||||
(vector-ref (cport-symtab cp) symref)
|
(symtab-lookup cp symref)
|
||||||
(decode-mark-map alist))]
|
(decode-mark-map alist))]
|
||||||
[(list* (? list? nested) alist)
|
[(list* (? list? nested) alist)
|
||||||
(make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))]))
|
(make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))])))
|
||||||
|
|
||||||
|
(define stx-memo (make-memo))
|
||||||
|
; XXX More memo use
|
||||||
(define (decode-stx cp v)
|
(define (decode-stx cp v)
|
||||||
|
(with-memo stx-memo v
|
||||||
(if (integer? v)
|
(if (integer? v)
|
||||||
(unmarshal-stx-get/decode cp v decode-stx)
|
(unmarshal-stx-get/decode cp v decode-stx)
|
||||||
(let loop ([v v])
|
(let loop ([v v])
|
||||||
|
|
@ -533,7 +542,8 @@
|
||||||
[else (error 'decode-wraps "bad datum+wrap: ~.s" v)])])
|
[else (error 'decode-wraps "bad datum+wrap: ~.s" v)])])
|
||||||
(let* ([wraps (decode-wraps cp encoded-wraps)]
|
(let* ([wraps (decode-wraps cp encoded-wraps)]
|
||||||
[marks (decode-marks cp cert-marks)]
|
[marks (decode-marks cp cert-marks)]
|
||||||
[add-wrap (lambda (v) (make-wrapped v wraps marks))])
|
[wrapped-memo (make-memo)]
|
||||||
|
[add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))])
|
||||||
(cond
|
(cond
|
||||||
[(pair? v)
|
[(pair? v)
|
||||||
(if (eq? #t (car v))
|
(if (eq? #t (car v))
|
||||||
|
|
@ -578,14 +588,12 @@
|
||||||
make-prefab-struct
|
make-prefab-struct
|
||||||
k
|
k
|
||||||
(map loop (struct->list v)))))]
|
(map loop (struct->list v)))))]
|
||||||
[else (add-wrap v)]))))))
|
[else (add-wrap v)])))))))
|
||||||
|
|
||||||
(define (decode-wraps cp w)
|
(define wrape-memo (make-memo))
|
||||||
; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252)
|
(define (decode-wrape cp a)
|
||||||
(if (integer? w)
|
(define (aloop a) (decode-wrape cp a))
|
||||||
(unmarshal-stx-get/decode cp w decode-wraps)
|
(with-memo wrape-memo a
|
||||||
(map (lambda (a)
|
|
||||||
(let aloop ([a a])
|
|
||||||
; A wrap-elem is either
|
; A wrap-elem is either
|
||||||
(cond
|
(cond
|
||||||
; A reference
|
; A reference
|
||||||
|
|
@ -619,23 +627,7 @@
|
||||||
(make-module-rename phase
|
(make-module-rename phase
|
||||||
(if kind 'marked 'normal)
|
(if kind 'marked 'normal)
|
||||||
set-id
|
set-id
|
||||||
(map (local [(define (phase? v)
|
(map (curry decode-all-from-module cp) unmarshals)
|
||||||
(or (number? v) (not v)))]
|
|
||||||
(match-lambda
|
|
||||||
[(list* path (? phase? phase) (? phase? src-phase)
|
|
||||||
(list exn ...) prefix)
|
|
||||||
(make-all-from-module
|
|
||||||
(parse-module-path-index cp path)
|
|
||||||
phase src-phase exn (vector prefix))]
|
|
||||||
[(list* path (? phase? phase) (list exn ...) (? phase? src-phase))
|
|
||||||
(make-all-from-module
|
|
||||||
(parse-module-path-index cp path)
|
|
||||||
phase src-phase exn #f)]
|
|
||||||
[(list* path (? phase? phase) (? phase? src-phase))
|
|
||||||
(make-all-from-module
|
|
||||||
(parse-module-path-index cp path)
|
|
||||||
phase src-phase #f #f)]))
|
|
||||||
unmarshals)
|
|
||||||
(decode-renames renames)
|
(decode-renames renames)
|
||||||
mark-renames
|
mark-renames
|
||||||
(and plus-kern? 'plus-kern)))]
|
(and plus-kern? 'plus-kern)))]
|
||||||
|
|
@ -653,7 +645,34 @@
|
||||||
(parse-module-path-index cp dest))]
|
(parse-module-path-index cp dest))]
|
||||||
[else (error 'parse "bad phase shift: ~e" a)])]
|
[else (error 'parse "bad phase shift: ~e" a)])]
|
||||||
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
|
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
|
||||||
w)))
|
|
||||||
|
(define all-from-module-memo (make-memo))
|
||||||
|
(define (decode-all-from-module cp afm)
|
||||||
|
(define (phase? v)
|
||||||
|
(or (number? v) (not v)))
|
||||||
|
(with-memo all-from-module-memo afm
|
||||||
|
(match afm
|
||||||
|
[(list* path (? phase? phase) (? phase? src-phase)
|
||||||
|
(list exn ...) prefix)
|
||||||
|
(make-all-from-module
|
||||||
|
(parse-module-path-index cp path)
|
||||||
|
phase src-phase exn (vector prefix))]
|
||||||
|
[(list* path (? phase? phase) (list exn ...) (? phase? src-phase))
|
||||||
|
(make-all-from-module
|
||||||
|
(parse-module-path-index cp path)
|
||||||
|
phase src-phase exn #f)]
|
||||||
|
[(list* path (? phase? phase) (? phase? src-phase))
|
||||||
|
(make-all-from-module
|
||||||
|
(parse-module-path-index cp path)
|
||||||
|
phase src-phase #f #f)])))
|
||||||
|
|
||||||
|
(define wraps-memo (make-memo))
|
||||||
|
(define (decode-wraps cp w)
|
||||||
|
(with-memo wraps-memo w
|
||||||
|
; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252)
|
||||||
|
(if (integer? w)
|
||||||
|
(unmarshal-stx-get/decode cp w decode-wraps)
|
||||||
|
(map (curry decode-wrape cp) w))))
|
||||||
|
|
||||||
(define (in-vector* v n)
|
(define (in-vector* v n)
|
||||||
(make-do-sequence
|
(make-do-sequence
|
||||||
|
|
@ -665,22 +684,24 @@
|
||||||
(λ _ #t)
|
(λ _ #t)
|
||||||
(λ _ #t)))))
|
(λ _ #t)))))
|
||||||
|
|
||||||
(define (decode-renames renames)
|
(define nominal-path-memo (make-memo))
|
||||||
(define decode-nominal-path
|
(define (decode-nominal-path np)
|
||||||
(match-lambda
|
(with-memo nominal-path-memo np
|
||||||
|
(match np
|
||||||
[(cons nominal-path (cons import-phase nominal-phase))
|
[(cons nominal-path (cons import-phase nominal-phase))
|
||||||
(make-phased-nominal-path nominal-path import-phase nominal-phase)]
|
(make-phased-nominal-path nominal-path import-phase nominal-phase)]
|
||||||
[(cons nominal-path import-phase)
|
[(cons nominal-path import-phase)
|
||||||
(make-imported-nominal-path nominal-path import-phase)]
|
(make-imported-nominal-path nominal-path import-phase)]
|
||||||
[nominal-path
|
[nominal-path
|
||||||
(make-simple-nominal-path nominal-path)]))
|
(make-simple-nominal-path nominal-path)])))
|
||||||
|
|
||||||
; XXX Weird test copied from C code. Matthew?
|
; XXX Weird test copied from C code. Matthew?
|
||||||
(define (nom_mod_p p)
|
(define (nom_mod_p p)
|
||||||
(and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p)))))
|
(and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p)))))
|
||||||
|
|
||||||
(for/list ([(k v) (in-vector* renames 2)])
|
(define rename-v-memo (make-memo))
|
||||||
(cons k
|
(define (decode-rename-v v)
|
||||||
|
(with-memo rename-v-memo v
|
||||||
(match v
|
(match v
|
||||||
[(list-rest path phase export-name nominal-path nominal-export-name)
|
[(list-rest path phase export-name nominal-path nominal-export-name)
|
||||||
(make-phased-module-binding path
|
(make-phased-module-binding path
|
||||||
|
|
@ -698,7 +719,13 @@
|
||||||
[(cons module-path-index export-name)
|
[(cons module-path-index export-name)
|
||||||
(make-exported-module-binding module-path-index export-name)]
|
(make-exported-module-binding module-path-index export-name)]
|
||||||
[module-path-index
|
[module-path-index
|
||||||
(make-simple-module-binding module-path-index)]))))
|
(make-simple-module-binding module-path-index)])))
|
||||||
|
|
||||||
|
(define renames-memo (make-memo))
|
||||||
|
(define (decode-renames renames)
|
||||||
|
(with-memo renames-memo renames
|
||||||
|
(for/list ([(k v) (in-vector* renames 2)])
|
||||||
|
(cons k (decode-rename-v v)))))
|
||||||
|
|
||||||
(define (parse-module-path-index cp s)
|
(define (parse-module-path-index cp s)
|
||||||
s)
|
s)
|
||||||
|
|
@ -734,7 +761,6 @@
|
||||||
[read-accept-dot #t]
|
[read-accept-dot #t]
|
||||||
[read-accept-infix-dot #t]
|
[read-accept-infix-dot #t]
|
||||||
[read-accept-quasiquote #t]
|
[read-accept-quasiquote #t]
|
||||||
;; Use a readtable for special path support in escaped:
|
|
||||||
[current-readtable
|
[current-readtable
|
||||||
(make-readtable
|
(make-readtable
|
||||||
#f
|
#f
|
||||||
|
|
@ -910,10 +936,10 @@
|
||||||
(make-application (read-compact cp)
|
(make-application (read-compact cp)
|
||||||
(for/list ([i (in-range c)])
|
(for/list ([i (in-range c)])
|
||||||
(read-compact cp))))]
|
(read-compact cp))))]
|
||||||
[(closure)
|
[(closure) ; XXX The use of indirect may be an artifact from pre-placeholder days
|
||||||
(let* ([l (read-compact-number cp)]
|
(let* ([l (read-compact-number cp)]
|
||||||
[ind (make-indirect #f)])
|
[ind (make-indirect #f)])
|
||||||
(placeholder-set! (vector-ref (cport-symtab cp) l) ind)
|
(symtab-write! cp l ind)
|
||||||
(let* ([v (read-compact cp)]
|
(let* ([v (read-compact cp)]
|
||||||
[cl (make-closure v (gensym
|
[cl (make-closure v (gensym
|
||||||
(let ([s (lam-name v)])
|
(let ([s (lam-name v)])
|
||||||
|
|
@ -941,15 +967,22 @@
|
||||||
(if decoded?
|
(if decoded?
|
||||||
v2
|
v2
|
||||||
(let ([dv2 (decode-stx cp v2)])
|
(let ([dv2 (decode-stx cp v2)])
|
||||||
(placeholder-set! (vector-ref (cport-symtab cp) pos) dv2)
|
(symtab-write! cp pos dv2)
|
||||||
(vector-set! (cport-decoded cp) pos #t)
|
(vector-set! (cport-decoded cp) pos #t)
|
||||||
dv2)))
|
dv2)))
|
||||||
|
|
||||||
|
(define (symtab-write! cp i v)
|
||||||
|
(placeholder-set! (vector-ref (cport-symtab cp) i) v))
|
||||||
|
|
||||||
|
(define (symtab-lookup cp i)
|
||||||
|
(when (mark-parameter-first read-sym-mark)
|
||||||
|
(dict-update! debug-symrefs (mark-parameter-first read-sym-mark) (λ (last) (cons i last)) empty))
|
||||||
|
(vector-ref (cport-symtab cp) i))
|
||||||
|
|
||||||
(require unstable/markparam)
|
(require unstable/markparam)
|
||||||
(define read-sym-mark (mark-parameter))
|
(define read-sym-mark (mark-parameter))
|
||||||
(define (read-sym cp i)
|
(define (read-sym cp i)
|
||||||
(define symtab (cport-symtab cp))
|
(define ph (symtab-lookup cp i))
|
||||||
(define ph (vector-ref symtab i))
|
|
||||||
; We are reading this already, so return the placeholder
|
; We are reading this already, so return the placeholder
|
||||||
(if (memq i (mark-parameter-all read-sym-mark))
|
(if (memq i (mark-parameter-all read-sym-mark))
|
||||||
ph
|
ph
|
||||||
|
|
@ -1003,11 +1036,17 @@
|
||||||
(define symtab
|
(define symtab
|
||||||
(build-vector symtabsize (λ (i) (make-placeholder nr))))
|
(build-vector symtabsize (λ (i) (make-placeholder nr))))
|
||||||
|
|
||||||
|
(set! debug-symrefs (make-vector symtabsize empty))
|
||||||
|
|
||||||
(define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
|
(define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
|
||||||
|
|
||||||
(for ([i (in-range 1 symtabsize)])
|
(for ([i (in-range 1 symtabsize)])
|
||||||
(read-sym cp i))
|
(read-sym cp i))
|
||||||
|
|
||||||
|
(for ([i (in-naturals)]
|
||||||
|
[v (in-vector debug-symrefs)])
|
||||||
|
(printf "~a: ~a~n" i v))
|
||||||
|
|
||||||
#;(for ([i (in-naturals)]
|
#;(for ([i (in-naturals)]
|
||||||
[v (in-vector (cport-symtab cp))])
|
[v (in-vector (cport-symtab cp))])
|
||||||
(printf "~a: ~s~n~n" i (placeholder-get v)))
|
(printf "~a: ~s~n~n" i (placeholder-get v)))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user