2ada6d0e89
- the `lam' structure from `compiler/zo-struct' changed to include a `toplevel-map' field This change helps solve a finalization problem in `racket/draw', which in turn sigificantly reduces the peak memory use of `raco setup' during the doc-building phase (because some documents load `racket/draw' to render images, and multiple copies of `racket/draw' were retained before finalization was fixed). The change is an extreme way to solve a specific finalization problem, but it's a kind of space-safety improvement; space safety almost never matters, but when it does, then working around a lack of space safety is practically impossible. In this case, it's not clear how to otherwise solve the `racket/draw' finalization problem. The improvement doesn't change the representation of closures, but it requires special cooperation with the GC. All closures in a module continue to share the same array of globals (plus syntax objects); that is, instead of completely flat closures, Racket uses a two-level environment where top-/module-level variables are grouped together. The code half of a closure now records which top-/module-level variables the body code actually uses, and the mark phase of GC consults this information to retain only parts of the top-/module-level environment frame that are actually used by some closure (or all of the frame if it is accessible through some other route). In other words, the GC supports a kind of "dependent reference" to an array that is indexed by positions into the array --- except that the code is more in the "Racket" directory instead of the "GC" directory, since it's so specific to the closure representation.
1095 lines
41 KiB
Racket
1095 lines
41 KiB
Racket
#lang scheme/base
|
|
(require mzlib/etc
|
|
racket/function
|
|
scheme/match
|
|
scheme/list
|
|
unstable/struct
|
|
compiler/zo-structs
|
|
racket/dict
|
|
racket/set)
|
|
|
|
(provide zo-parse)
|
|
(provide (all-from-out compiler/zo-structs))
|
|
|
|
#| Unresolved Issues
|
|
|
|
The order of indirect-et-provides, indirect-syntax-provides, indirect-provides was changed, is that okay?
|
|
|
|
orig-port of cport struct is never used, is it needed?
|
|
|
|
Lines 628, 630 seem to be only for debugging and should probably throw errors
|
|
|
|
vector and pair cases of decode-wraps seem to do different things from the corresponding C code
|
|
|
|
Line 816: This should be an eqv placeholder (but they don't exist)
|
|
|
|
Line 634: Export registry is always matched as false, but might not be
|
|
|
|
What are the real differences between the module-binding cases?
|
|
|
|
I think parse-module-path-index was only used for debugging, so it is short-circuited now
|
|
|
|
|#
|
|
;; ----------------------------------------
|
|
;; Bytecode unmarshalers for various forms
|
|
|
|
(define (read-toplevel v)
|
|
(define SCHEME_TOPLEVEL_CONST #x01)
|
|
(define SCHEME_TOPLEVEL_READY #x02)
|
|
(match v
|
|
[(cons depth (cons pos flags))
|
|
(make-toplevel depth pos
|
|
(positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST))
|
|
(positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))]
|
|
[(cons depth pos)
|
|
(make-toplevel depth pos #f #f)]))
|
|
|
|
(define (read-topsyntax v)
|
|
(match v
|
|
[`(,depth ,pos . ,midpt)
|
|
(make-topsyntax depth pos midpt)]))
|
|
|
|
(define (read-variable v)
|
|
(if (symbol? v)
|
|
(make-global-bucket v)
|
|
(error "expected a symbol")))
|
|
|
|
(define (do-not-read-variable v)
|
|
(error "should not get here"))
|
|
|
|
(define (read-compilation-top v)
|
|
(match v
|
|
[`(,ld ,prefix . ,code)
|
|
(unless (prefix? prefix)
|
|
(error 'bad "not prefix ~a" prefix))
|
|
(make-compilation-top ld prefix code)]))
|
|
|
|
(define (read-resolve-prefix v)
|
|
(let-values ([(v unsafe?) (if (integer? (car v))
|
|
(values v #f)
|
|
(values (cdr v) #t))])
|
|
(match v
|
|
[`(,i ,tv . ,sv)
|
|
; XXX Why not leave them as vectors and change the contract?
|
|
(make-prefix i (vector->list tv) (vector->list sv))])))
|
|
|
|
(define read-free-id-info
|
|
(match-lambda
|
|
[(vector mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0) ; I have no idea what these mean
|
|
(make-free-id-info mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0)]))
|
|
|
|
(define (read-unclosed-procedure v)
|
|
(define CLOS_HAS_REST 1)
|
|
(define CLOS_HAS_REF_ARGS 2)
|
|
(define CLOS_PRESERVES_MARKS 4)
|
|
(define CLOS_NEED_REST_CLEAR 8)
|
|
(define CLOS_IS_METHOD 16)
|
|
(define CLOS_SINGLE_RESULT 32)
|
|
(define BITS_PER_MZSHORT 32)
|
|
(match v
|
|
[`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest)
|
|
(let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))])
|
|
(let*-values ([(closure-size closed-over body)
|
|
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
|
|
(values (vector-length v) v rest)
|
|
(values v (car rest) (cdr rest)))]
|
|
[(check-bit) (lambda (i)
|
|
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
|
|
0
|
|
(let ([byte (vector-ref closed-over
|
|
(+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))])
|
|
(+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT))
|
|
1
|
|
0)
|
|
(if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT)))
|
|
2
|
|
0)))))]
|
|
[(arg-types) (let ([num-params ((if rest? sub1 values) num-params)])
|
|
(for/list ([i (in-range num-params)])
|
|
(case (check-bit i)
|
|
[(0) 'val]
|
|
[(1) 'ref]
|
|
[(2) 'flonum])))]
|
|
[(closure-types) (for/list ([i (in-range closure-size)]
|
|
[j (in-naturals num-params)])
|
|
(case (check-bit j)
|
|
[(0) 'val/ref]
|
|
[(2) 'flonum]))])
|
|
(make-lam name
|
|
(append
|
|
(if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks))
|
|
(if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method))
|
|
(if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result))
|
|
(if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args))
|
|
(if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null))
|
|
(if (and rest? (num-params . > . 0))
|
|
(sub1 num-params)
|
|
num-params)
|
|
arg-types
|
|
rest?
|
|
(if (= closure-size (vector-length closed-over))
|
|
closed-over
|
|
(let ([v2 (make-vector closure-size)])
|
|
(vector-copy! v2 0 closed-over 0 closure-size)
|
|
v2))
|
|
closure-types
|
|
(and tl-map
|
|
(let* ([bits (if (exact-integer? tl-map)
|
|
tl-map
|
|
(for/fold ([i 0]) ([v (in-list tl-map)]
|
|
[s (in-naturals)])
|
|
(bitwise-ior i (arithmetic-shift v 16))))]
|
|
[len (integer-length bits)])
|
|
(list->set
|
|
(let loop ([bit 0])
|
|
(cond
|
|
[(bit . >= . len) null]
|
|
[(bitwise-bit-set? bits bit)
|
|
(cons bit (loop (add1 bit)))]
|
|
[else (loop (add1 bit))])))))
|
|
max-let-depth
|
|
body)))]))
|
|
|
|
(define (read-let-value v)
|
|
(match v
|
|
[`(,count ,pos ,boxes? ,rhs . ,body)
|
|
(make-install-value count pos boxes? rhs body)]))
|
|
|
|
(define (read-let-void v)
|
|
(match v
|
|
[`(,count ,boxes? . ,body)
|
|
(make-let-void count boxes? body)]))
|
|
|
|
(define (read-letrec v)
|
|
(match v
|
|
[`(,count ,body . ,procs)
|
|
(make-let-rec procs body)]))
|
|
|
|
(define (read-with-cont-mark v)
|
|
(match v
|
|
[`(,key ,val . ,body)
|
|
(make-with-cont-mark key val body)]))
|
|
|
|
(define (read-sequence v)
|
|
(make-seq v))
|
|
|
|
; XXX Allocates unnessary list
|
|
(define (read-define-values v)
|
|
(make-def-values
|
|
(cdr (vector->list v))
|
|
(vector-ref v 0)))
|
|
|
|
; XXX Allocates unnessary list
|
|
(define (read-define-syntaxes mk v)
|
|
(mk (list-tail (vector->list v) 4)
|
|
(vector-ref v 0)
|
|
(vector-ref v 1)
|
|
(vector-ref v 2)
|
|
#;(vector-ref v 3)))
|
|
|
|
(define (read-define-syntax v)
|
|
(read-define-syntaxes make-def-syntaxes v))
|
|
|
|
(define (read-define-for-syntax v)
|
|
(read-define-syntaxes make-def-for-syntax v))
|
|
|
|
(define (read-set! v)
|
|
(make-assign (cadr v) (cddr v) (car v)))
|
|
|
|
(define (read-case-lambda v)
|
|
(make-case-lam (car v) (cdr v)))
|
|
|
|
(define (read-begin0 v)
|
|
(match v
|
|
[(struct seq (exprs))
|
|
(make-beg0 exprs)]))
|
|
|
|
(define (read-boxenv v)
|
|
(make-boxenv (car v) (cdr v)))
|
|
(define (read-require v)
|
|
(make-req (cdr v) (car v)))
|
|
(define (read-#%variable-ref v)
|
|
(make-varref v))
|
|
(define (read-apply-values v)
|
|
(make-apply-values (car v) (cdr v)))
|
|
(define (read-splice v)
|
|
(make-splice (seq-forms v)))
|
|
|
|
(define (in-list* l n)
|
|
(make-do-sequence
|
|
(lambda ()
|
|
(values (lambda (l) (apply values (take l n)))
|
|
(lambda (l) (drop l n))
|
|
l
|
|
(lambda (l) (>= (length l) n))
|
|
(lambda _ #t)
|
|
(lambda _ #t)))))
|
|
|
|
(define (read-module v)
|
|
(match v
|
|
[`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional?
|
|
,rename ,max-let-depth ,dummy
|
|
,prefix
|
|
,indirect-et-provides ,num-indirect-et-provides
|
|
,indirect-syntax-provides ,num-indirect-syntax-provides
|
|
,indirect-provides ,num-indirect-provides
|
|
,protects ,et-protects
|
|
,provide-phase-count . ,rest)
|
|
(let ([phase-data (take rest (* 9 provide-phase-count))])
|
|
(match (list-tail rest (* 9 provide-phase-count))
|
|
[`(,syntax-body ,body
|
|
,requires ,syntax-requires ,template-requires ,label-requires
|
|
,more-requires-count . ,more-requires)
|
|
(make-mod name srcname self-modidx
|
|
prefix (let loop ([l phase-data])
|
|
(if (null? l)
|
|
null
|
|
(let ([num-vars (list-ref l 7)]
|
|
[ps (for/list ([name (in-vector (list-ref l 6))]
|
|
[src (in-vector (list-ref l 5))]
|
|
[src-name (in-vector (list-ref l 4))]
|
|
[nom-src (or (list-ref l 3)
|
|
(in-cycle (in-value #f)))]
|
|
[src-phase (or (list-ref l 2)
|
|
(in-cycle (in-value #f)))]
|
|
[protected? (or (case (car l)
|
|
[(0) protects]
|
|
[(1) et-protects]
|
|
[else #f])
|
|
(in-cycle (in-value #f)))]
|
|
[insp (or (list-ref l 1)
|
|
(in-cycle (in-value #f)))])
|
|
(make-provided name src src-name
|
|
(or nom-src src)
|
|
(if src-phase 1 0)
|
|
protected?
|
|
insp))])
|
|
(if (null? ps)
|
|
(loop (list-tail l 9))
|
|
(cons
|
|
(list
|
|
(car l)
|
|
(take ps num-vars)
|
|
(drop ps num-vars))
|
|
(loop (list-tail l 9)))))))
|
|
(list*
|
|
(cons 0 requires)
|
|
(cons 1 syntax-requires)
|
|
(cons -1 template-requires)
|
|
(cons #f label-requires)
|
|
(for/list ([(phase reqs) (in-list* more-requires 2)])
|
|
(cons phase reqs)))
|
|
(vector->list body)
|
|
(map (lambda (sb)
|
|
(match sb
|
|
[(? def-syntaxes?) sb]
|
|
[(? def-for-syntax?) sb]
|
|
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
|
|
((if for-stx?
|
|
make-def-for-syntax
|
|
make-def-syntaxes)
|
|
(if (list? ids) ids (list ids)) expr prefix max-let-depth)]))
|
|
(vector->list syntax-body))
|
|
(list (vector->list indirect-provides)
|
|
(vector->list indirect-syntax-provides)
|
|
(vector->list indirect-et-provides))
|
|
max-let-depth
|
|
dummy
|
|
lang-info
|
|
rename)]))]))
|
|
(define (read-module-wrap v)
|
|
v)
|
|
|
|
;; ----------------------------------------
|
|
;; Unmarshal dispatch for various types
|
|
|
|
(define (read-more-syntax v)
|
|
(let ([id (car v)]
|
|
[v (cdr v)])
|
|
;; This is the ..._EXPD mapping from "schpriv.h":
|
|
(case id
|
|
[(0) (read-define-values v)]
|
|
[(1) (read-define-syntax v)]
|
|
[(2) (read-set! v)]
|
|
[(3) v] ; a case-lam already
|
|
[(4) (read-begin0 v)]
|
|
[(5) (read-boxenv v)]
|
|
[(6) (read-module-wrap v)]
|
|
[(7) (read-require v)]
|
|
[(8) (read-define-for-syntax v)]
|
|
[(9) (read-#%variable-ref v)]
|
|
[(10) (read-apply-values v)]
|
|
[(11) (read-splice v)]
|
|
[else (error 'read-mode-unsyntax "unknown id: ~e" id)])))
|
|
|
|
;; Type mappings from "stypes.h":
|
|
(define (int->type i)
|
|
(case i
|
|
[(0) 'toplevel-type]
|
|
[(3) 'syntax-type]
|
|
[(7) 'sequence-type]
|
|
[(9) 'unclosed-procedure-type]
|
|
[(10) 'let-value-type]
|
|
[(11) 'let-void-type]
|
|
[(12) 'letrec-type]
|
|
[(14) 'with-cont-mark-type]
|
|
[(15) 'quote-syntax-type]
|
|
[(24) 'variable-type]
|
|
[(25) 'module-variable-type]
|
|
[(99) 'case-lambda-sequence-type]
|
|
[(100) 'begin0-sequence-type]
|
|
[(103) 'module-type]
|
|
[(105) 'resolve-prefix-type]
|
|
[(154) 'free-id-info-type]
|
|
[else (error 'int->type "unknown type: ~e" i)]))
|
|
|
|
(define type-readers
|
|
(make-immutable-hash
|
|
(list
|
|
(cons 'toplevel-type read-toplevel)
|
|
(cons 'syntax-type read-more-syntax)
|
|
(cons 'sequence-type read-sequence)
|
|
(cons 'unclosed-procedure-type read-unclosed-procedure)
|
|
(cons 'let-value-type read-let-value)
|
|
(cons 'let-void-type read-let-void)
|
|
(cons 'letrec-type read-letrec)
|
|
(cons 'with-cont-mark-type read-with-cont-mark)
|
|
(cons 'quote-syntax-type read-topsyntax)
|
|
(cons 'variable-type read-variable)
|
|
(cons 'module-variable-type do-not-read-variable)
|
|
(cons 'compilation-top-type read-compilation-top)
|
|
(cons 'case-lambda-sequence-type read-case-lambda)
|
|
(cons 'begin0-sequence-type read-sequence)
|
|
(cons 'module-type read-module)
|
|
(cons 'resolve-prefix-type read-resolve-prefix)
|
|
(cons 'free-id-info-type read-free-id-info))))
|
|
|
|
(define (get-reader type)
|
|
(hash-ref type-readers type
|
|
(λ ()
|
|
(error 'read-marshalled "reader for ~a not implemented" type))))
|
|
|
|
;; ----------------------------------------
|
|
;; Lowest layer of bytecode parsing
|
|
|
|
(define (split-so all-short so)
|
|
(define n (if (zero? all-short) 4 2))
|
|
(let loop ([so so])
|
|
(if (zero? (bytes-length so))
|
|
null
|
|
(cons (integer-bytes->integer (subbytes so 0 n) #f #f)
|
|
(loop (subbytes so n))))))
|
|
|
|
(define (read-simple-number p)
|
|
(integer-bytes->integer (read-bytes 4 p) #f #f))
|
|
|
|
(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets decoded rns mpis))
|
|
(define (cport-get-bytes cp len)
|
|
(define port (cport-orig-port cp))
|
|
(define pos (cport-pos cp))
|
|
(file-position port (+ (cport-bytes-start cp) pos))
|
|
(read-bytes len port))
|
|
(define (cport-get-byte cp pos)
|
|
(define port (cport-orig-port cp))
|
|
(file-position port (+ (cport-bytes-start cp) pos))
|
|
(read-byte port))
|
|
|
|
(define (cport-rpos cp)
|
|
(+ (cport-pos cp) (cport-shared-start cp)))
|
|
|
|
(define (cp-getc cp)
|
|
(begin-with-definitions
|
|
(when ((cport-pos cp) . >= . (cport-size cp))
|
|
(error "off the end"))
|
|
(define r (cport-get-byte cp (cport-pos cp)))
|
|
(set-cport-pos! cp (add1 (cport-pos cp)))
|
|
r))
|
|
|
|
(define small-list-max 65)
|
|
(define cpt-table
|
|
;; The "schcpt.h" mapping
|
|
`([0 escape]
|
|
[1 symbol]
|
|
[2 symref]
|
|
[3 weird-symbol]
|
|
[4 keyword]
|
|
[5 byte-string]
|
|
[6 string]
|
|
[7 char]
|
|
[8 int]
|
|
[9 null]
|
|
[10 true]
|
|
[11 false]
|
|
[12 void]
|
|
[13 box]
|
|
[14 pair]
|
|
[15 list]
|
|
[16 vector]
|
|
[17 hash-table]
|
|
[18 stx]
|
|
[19 let-one-flonum]
|
|
[20 marshalled]
|
|
[21 quote]
|
|
[22 reference]
|
|
[23 local]
|
|
[24 local-unbox]
|
|
[25 svector]
|
|
[26 application]
|
|
[27 let-one]
|
|
[28 branch]
|
|
[29 module-index]
|
|
[30 module-var]
|
|
[31 path]
|
|
[32 closure]
|
|
[33 delayed]
|
|
[34 prefab]
|
|
[35 let-one-unused]
|
|
[36 60 small-number]
|
|
[60 80 small-symbol]
|
|
[80 92 small-marshalled]
|
|
[92 ,(+ 92 small-list-max) small-proper-list]
|
|
[,(+ 92 small-list-max) 192 small-list]
|
|
[192 207 small-local]
|
|
[207 222 small-local-unbox]
|
|
[222 247 small-svector]
|
|
[248 small-application2]
|
|
[249 small-application3]
|
|
[247 255 small-application]))
|
|
|
|
(define (cpt-table-lookup i)
|
|
(for/or ([ent cpt-table])
|
|
(match ent
|
|
[(list k sym) (and (= k i) (cons k sym))]
|
|
[(list k k* sym)
|
|
(and (<= k i)
|
|
(< i k*)
|
|
(cons k sym))])))
|
|
|
|
(define (read-compact-bytes port c)
|
|
(begin0
|
|
(cport-get-bytes port c)
|
|
(set-cport-pos! port (+ c (cport-pos port)))))
|
|
|
|
(define (read-compact-chars port c)
|
|
(bytes->string/utf-8 (read-compact-bytes port c)))
|
|
|
|
(define (read-compact-list c proper port)
|
|
(cond [(= 0 c)
|
|
(if proper null (read-compact port))]
|
|
[else (cons (read-compact port) (read-compact-list (sub1 c) proper port))]))
|
|
|
|
(define (read-compact-number port)
|
|
(define flag (cp-getc port))
|
|
(cond [(< flag 128)
|
|
flag]
|
|
[(zero? (bitwise-and flag #x40))
|
|
(let ([a (cp-getc port)])
|
|
(+ (a . << . 6) (bitwise-and flag 63)))]
|
|
[(zero? (bitwise-and flag #x20))
|
|
(- (bitwise-and flag #x1F))]
|
|
[else
|
|
(let ([a (cp-getc port)]
|
|
[b (cp-getc port)]
|
|
[c (cp-getc port)]
|
|
[d (cp-getc port)])
|
|
(let ([n (integer-bytes->integer (bytes a b c d) #f #f)])
|
|
(if (zero? (bitwise-and flag #x10))
|
|
(- n)
|
|
n)))]))
|
|
|
|
(define (read-compact-svector port n)
|
|
(define v (make-vector n))
|
|
(for ([i (in-range n)])
|
|
(vector-set! v (sub1 (- n i)) (read-compact-number port)))
|
|
v)
|
|
|
|
(define (read-marshalled type port)
|
|
(let* ([type (if (number? type) (int->type type) type)]
|
|
[l (read-compact port)]
|
|
[reader (get-reader type)])
|
|
(reader l)))
|
|
|
|
(define (make-local unbox? pos flags)
|
|
(define SCHEME_LOCAL_CLEAR_ON_READ #x01)
|
|
(define SCHEME_LOCAL_OTHER_CLEARS #x02)
|
|
(define SCHEME_LOCAL_FLONUM #x03)
|
|
(make-localref unbox? pos
|
|
(= flags SCHEME_LOCAL_CLEAR_ON_READ)
|
|
(= flags SCHEME_LOCAL_OTHER_CLEARS)
|
|
(= flags SCHEME_LOCAL_FLONUM)))
|
|
|
|
(define (a . << . b)
|
|
(arithmetic-shift a b))
|
|
|
|
(define-struct not-ready ())
|
|
|
|
;; ----------------------------------------
|
|
;; Syntax unmarshaling
|
|
(define (make-memo) (make-weak-hash))
|
|
(define (with-memo* mt arg thnk)
|
|
(hash-ref! mt arg thnk))
|
|
(define-syntax-rule (with-memo mt arg body ...)
|
|
(with-memo* mt arg (λ () body ...)))
|
|
|
|
(define (decode-mark-map alist)
|
|
alist)
|
|
|
|
(define marks-memo (make-memo))
|
|
(define (decode-marks cp ms)
|
|
(with-memo marks-memo ms
|
|
(match ms
|
|
[#f #f]
|
|
[(list* #f (? number? symref) alist)
|
|
(make-certificate:ref
|
|
(symtab-lookup cp symref)
|
|
(decode-mark-map alist))]
|
|
[(list* (? list? nested) alist)
|
|
(make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))]
|
|
[alist
|
|
(make-certificate:plain (decode-mark-map alist))])))
|
|
|
|
(define stx-memo (make-memo))
|
|
; XXX More memo use
|
|
(define (decode-stx cp v)
|
|
(with-memo stx-memo v
|
|
(if (integer? v)
|
|
(unmarshal-stx-get/decode cp v decode-stx)
|
|
(let loop ([v v])
|
|
(let-values ([(cert-marks v encoded-wraps)
|
|
(match v
|
|
[`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)]
|
|
[`(,datum . ,wraps) (values #f datum wraps)]
|
|
[else (error 'decode-wraps "bad datum+wrap: ~.s" v)])])
|
|
(let* ([wraps (decode-wraps cp encoded-wraps)]
|
|
[marks (decode-marks cp cert-marks)]
|
|
[wrapped-memo (make-memo)]
|
|
[add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))])
|
|
(cond
|
|
[(pair? v)
|
|
(if (eq? #t (car v))
|
|
;; Share decoded wraps with all nested parts.
|
|
(let loop ([v (cdr v)])
|
|
(cond
|
|
[(pair? v)
|
|
(let ploop ([v v])
|
|
(cond
|
|
[(null? v) null]
|
|
[(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))]
|
|
[else (loop v)]))]
|
|
[(box? v) (add-wrap (box (loop (unbox v))))]
|
|
[(vector? v)
|
|
(add-wrap (list->vector (map loop (vector->list v))))]
|
|
[(prefab-struct-key v)
|
|
=> (lambda (k)
|
|
(add-wrap
|
|
(apply
|
|
make-prefab-struct
|
|
k
|
|
(map loop (struct->list v)))))]
|
|
[else (add-wrap v)]))
|
|
;; Decode sub-elements that have their own wraps:
|
|
(let-values ([(v counter) (if (exact-integer? (car v))
|
|
(values (cdr v) (car v))
|
|
(values v -1))])
|
|
(add-wrap
|
|
(let ploop ([v v][counter counter])
|
|
(cond
|
|
[(null? v) null]
|
|
[(or (not (pair? v)) (zero? counter)) (loop v)]
|
|
[(pair? v) (cons (loop (car v))
|
|
(ploop (cdr v) (sub1 counter)))])))))]
|
|
[(box? v) (add-wrap (box (loop (unbox v))))]
|
|
[(vector? v)
|
|
(add-wrap (list->vector (map loop (vector->list v))))]
|
|
[(prefab-struct-key v)
|
|
=> (lambda (k)
|
|
(add-wrap
|
|
(apply
|
|
make-prefab-struct
|
|
k
|
|
(map loop (struct->list v)))))]
|
|
[else (add-wrap v)])))))))
|
|
|
|
(define wrape-memo (make-memo))
|
|
(define (decode-wrape cp a)
|
|
(define (aloop a) (decode-wrape cp a))
|
|
(with-memo wrape-memo a
|
|
; A wrap-elem is either
|
|
(cond
|
|
; A reference
|
|
[(integer? a)
|
|
(unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))]
|
|
; A mark (not actually a number as the C says, but a (list <num>)
|
|
[(and (pair? a) (number? (car a)))
|
|
(make-wrap-mark (car a))]
|
|
|
|
[(vector? a)
|
|
(make-lexical-rename (vector-ref a 0) (vector-ref a 1)
|
|
(let ([top (+ (/ (- (vector-length a) 2) 2) 2)])
|
|
(let loop ([i 2])
|
|
(if (= i top)
|
|
null
|
|
(cons (cons (vector-ref a i)
|
|
(vector-ref a (+ (- top 2) i)))
|
|
(loop (+ i 1)))))))]
|
|
[(pair? a)
|
|
(let-values ([(plus-kern? a) (if (eq? (car a) #t)
|
|
(values #t (cdr a))
|
|
(values #f a))])
|
|
(match a
|
|
[`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames)
|
|
(let-values ([(unmarshals renames mark-renames)
|
|
(if (vector? maybe-unmarshals)
|
|
(values null maybe-unmarshals renames)
|
|
(values maybe-unmarshals
|
|
(car renames)
|
|
(cdr renames)))])
|
|
(make-module-rename phase
|
|
(if kind 'marked 'normal)
|
|
set-id
|
|
(map (curry decode-all-from-module cp) unmarshals)
|
|
(decode-renames renames)
|
|
mark-renames
|
|
(and plus-kern? 'plus-kern)))]
|
|
[else (error "bad module rename: ~e" a)]))]
|
|
[(boolean? a)
|
|
(make-top-level-rename a)]
|
|
[(symbol? a)
|
|
(make-mark-barrier a)]
|
|
[(box? a)
|
|
(match (unbox a)
|
|
[(list (? symbol?) ...) (make-prune (unbox a))]
|
|
[`#(,amt ,src ,dest #f)
|
|
(make-phase-shift amt
|
|
(parse-module-path-index cp src)
|
|
(parse-module-path-index cp dest))]
|
|
[else (error 'parse "bad phase shift: ~e" a)])]
|
|
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
|
|
|
|
(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)
|
|
(make-do-sequence
|
|
(λ ()
|
|
(values (λ (i) (vector->values v i (+ i n)))
|
|
(λ (i) (+ i n))
|
|
0
|
|
(λ (i) (>= (vector-length v) (+ i n)))
|
|
(λ _ #t)
|
|
(λ _ #t)))))
|
|
|
|
(define nominal-path-memo (make-memo))
|
|
(define (decode-nominal-path np)
|
|
(with-memo nominal-path-memo np
|
|
(match np
|
|
[(cons nominal-path (cons import-phase nominal-phase))
|
|
(make-phased-nominal-path nominal-path import-phase nominal-phase)]
|
|
[(cons nominal-path import-phase)
|
|
(make-imported-nominal-path nominal-path import-phase)]
|
|
[nominal-path
|
|
(make-simple-nominal-path nominal-path)])))
|
|
|
|
; XXX Weird test copied from C code. Matthew?
|
|
(define (nom_mod_p p)
|
|
(and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p)))))
|
|
|
|
(define rename-v-memo (make-memo))
|
|
(define (decode-rename-v v)
|
|
(with-memo rename-v-memo v
|
|
(match v
|
|
[(list-rest path phase export-name nominal-path nominal-export-name)
|
|
(make-phased-module-binding path
|
|
phase
|
|
export-name
|
|
(decode-nominal-path nominal-path)
|
|
nominal-export-name)]
|
|
[(list-rest path export-name nominal-path nominal-export-name)
|
|
(make-exported-nominal-module-binding path
|
|
export-name
|
|
(decode-nominal-path nominal-path)
|
|
nominal-export-name)]
|
|
[(cons module-path-index (? nom_mod_p nominal-path))
|
|
(make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))]
|
|
[(cons module-path-index export-name)
|
|
(make-exported-module-binding module-path-index export-name)]
|
|
[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)
|
|
s)
|
|
|
|
;; ----------------------------------------
|
|
;; Main parsing loop
|
|
|
|
(define (read-compact cp)
|
|
(let loop ([need-car 0] [proper #f])
|
|
(begin-with-definitions
|
|
(define ch (cp-getc cp))
|
|
(define-values (cpt-start cpt-tag)
|
|
(let ([x (cpt-table-lookup ch)])
|
|
(unless x
|
|
(error 'read-compact "unknown code : ~a" ch))
|
|
(values (car x) (cdr x))))
|
|
(define v
|
|
(case cpt-tag
|
|
[(delayed)
|
|
(let ([pos (read-compact-number cp)])
|
|
(read-sym cp pos))]
|
|
[(escape)
|
|
(let* ([len (read-compact-number cp)]
|
|
[s (cport-get-bytes cp len)])
|
|
(set-cport-pos! cp (+ (cport-pos cp) len))
|
|
(parameterize ([read-accept-compiled #t]
|
|
[read-accept-bar-quote #t]
|
|
[read-accept-box #t]
|
|
[read-accept-graph #t]
|
|
[read-case-sensitive #t]
|
|
[read-square-bracket-as-paren #t]
|
|
[read-curly-brace-as-paren #t]
|
|
[read-decimal-as-inexact #t]
|
|
[read-accept-dot #t]
|
|
[read-accept-infix-dot #t]
|
|
[read-accept-quasiquote #t]
|
|
[current-readtable
|
|
(make-readtable
|
|
#f
|
|
#\^
|
|
'dispatch-macro
|
|
(lambda (char port src line col pos)
|
|
(let ([b (read port)])
|
|
(unless (bytes? b)
|
|
(error 'read-escaped-path
|
|
"expected a byte string after #^"))
|
|
(let ([p (bytes->path b)])
|
|
(if (and (relative-path? p)
|
|
(current-load-relative-directory))
|
|
(build-path (current-load-relative-directory) p)
|
|
p)))))])
|
|
(read/recursive (open-input-bytes s))))]
|
|
[(reference)
|
|
(make-primval (read-compact-number cp))]
|
|
[(small-list small-proper-list)
|
|
(let* ([l (- ch cpt-start)]
|
|
[ppr (eq? cpt-tag 'small-proper-list)])
|
|
(if (positive? need-car)
|
|
(if (= l 1)
|
|
(cons (read-compact cp)
|
|
(if ppr null (read-compact cp)))
|
|
(read-compact-list l ppr cp))
|
|
(loop l ppr)))]
|
|
[(let-one let-one-flonum let-one-unused)
|
|
(make-let-one (read-compact cp) (read-compact cp)
|
|
(eq? cpt-tag 'let-one-flonum)
|
|
(eq? cpt-tag 'let-one-unused))]
|
|
[(branch)
|
|
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
|
|
[(module-index) (module-path-index-join (read-compact cp) (read-compact cp))]
|
|
[(module-var)
|
|
(let ([mod (read-compact cp)]
|
|
[var (read-compact cp)]
|
|
[pos (read-compact-number cp)])
|
|
(let-values ([(mod-phase pos)
|
|
(if (= pos -2)
|
|
(values 1 (read-compact-number cp))
|
|
(values 0 pos))])
|
|
(make-module-variable mod var pos mod-phase)))]
|
|
[(local-unbox)
|
|
(let* ([p* (read-compact-number cp)]
|
|
[p (if (< p* 0)
|
|
(- (add1 p*))
|
|
p*)]
|
|
[flags (if (< p* 0)
|
|
(read-compact-number cp)
|
|
0)])
|
|
(make-local #t p flags))]
|
|
[(path)
|
|
(let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))])
|
|
(if (relative-path? p)
|
|
(path->complete-path p (or (current-load-relative-directory)
|
|
(current-directory)))
|
|
p))]
|
|
[(small-number)
|
|
(let ([l (- ch cpt-start)])
|
|
l)]
|
|
[(int)
|
|
(read-compact-number cp)]
|
|
[(false) #f]
|
|
[(true) #t]
|
|
[(null) null]
|
|
[(void) (void)]
|
|
[(vector)
|
|
; XXX We should provide build-immutable-vector and write this as:
|
|
#;(build-immutable-vector (read-compact-number cp)
|
|
(lambda (i) (read-compact cp)))
|
|
; XXX Now it allocates an unnessary list AND vector
|
|
(let* ([n (read-compact-number cp)]
|
|
[lst (for/list ([i (in-range n)])
|
|
(read-compact cp))])
|
|
(vector->immutable-vector (list->vector lst)))]
|
|
[(pair)
|
|
(let* ([a (read-compact cp)]
|
|
[d (read-compact cp)])
|
|
(cons a d))]
|
|
[(list)
|
|
(let ([len (read-compact-number cp)])
|
|
(let loop ([i len])
|
|
(if (zero? i)
|
|
(read-compact cp)
|
|
(list* (read-compact cp)
|
|
(loop (sub1 i))))))]
|
|
[(prefab)
|
|
(let ([v (read-compact cp)])
|
|
; XXX This is faster than apply+->list, but can we avoid allocating the vector?
|
|
(call-with-values (lambda () (vector->values v))
|
|
make-prefab-struct))]
|
|
[(hash-table)
|
|
; XXX Allocates an unnessary list (maybe use for/hash(eq))
|
|
(let ([eq (read-compact-number cp)]
|
|
[len (read-compact-number cp)])
|
|
((case eq
|
|
[(0) make-hasheq-placeholder]
|
|
[(1) make-hash-placeholder]
|
|
[(2) make-hasheqv-placeholder])
|
|
(for/list ([i (in-range len)])
|
|
(cons (read-compact cp)
|
|
(read-compact cp)))))]
|
|
[(marshalled) (read-marshalled (read-compact-number cp) cp)]
|
|
[(stx)
|
|
(let ([v (make-reader-graph (read-compact cp))])
|
|
(make-stx (decode-stx cp v)))]
|
|
[(local local-unbox)
|
|
(let ([c (read-compact-number cp)]
|
|
[unbox? (eq? cpt-tag 'local-unbox)])
|
|
(if (negative? c)
|
|
(make-local unbox? (- (add1 c)) (read-compact-number cp))
|
|
(make-local unbox? c 0)))]
|
|
[(small-local)
|
|
(make-local #f (- ch cpt-start) 0)]
|
|
[(small-local-unbox)
|
|
(make-local #t (- ch cpt-start) 0)]
|
|
[(small-symbol)
|
|
(let ([l (- ch cpt-start)])
|
|
(string->symbol (read-compact-chars cp l)))]
|
|
[(symbol)
|
|
(let ([l (read-compact-number cp)])
|
|
(string->symbol (read-compact-chars cp l)))]
|
|
[(keyword)
|
|
(let ([l (read-compact-number cp)])
|
|
(string->keyword (read-compact-chars cp l)))]
|
|
[(byte-string)
|
|
(let ([l (read-compact-number cp)])
|
|
(read-compact-bytes cp l))]
|
|
[(string)
|
|
(let ([l (read-compact-number cp)]
|
|
[cl (read-compact-number cp)])
|
|
(read-compact-chars cp l))]
|
|
[(char)
|
|
(integer->char (read-compact-number cp))]
|
|
[(box)
|
|
(box (read-compact cp))]
|
|
[(quote)
|
|
(make-reader-graph
|
|
;; Nested escapes need to share graph references. So get inside the
|
|
;; read where `read/recursive' can be used:
|
|
(let ([rt (current-readtable)])
|
|
(parameterize ([current-readtable (make-readtable
|
|
#f
|
|
#\x 'terminating-macro
|
|
(lambda args
|
|
(parameterize ([current-readtable rt])
|
|
(read-compact cp))))])
|
|
(read (open-input-bytes #"x")))))]
|
|
[(symref)
|
|
(let* ([l (read-compact-number cp)])
|
|
(read-sym cp l))]
|
|
[(weird-symbol)
|
|
(let ([uninterned (read-compact-number cp)]
|
|
[str (read-compact-chars cp (read-compact-number cp))])
|
|
(if (= 1 uninterned)
|
|
; uninterned is equivalent to weird in the C implementation
|
|
(string->uninterned-symbol str)
|
|
; unreadable is equivalent to parallel in the C implementation
|
|
(string->unreadable-symbol str)))]
|
|
[(small-marshalled)
|
|
(read-marshalled (- ch cpt-start) cp)]
|
|
[(small-application2)
|
|
(make-application (read-compact cp)
|
|
(list (read-compact cp)))]
|
|
[(small-application3)
|
|
(make-application (read-compact cp)
|
|
(list (read-compact cp)
|
|
(read-compact cp)))]
|
|
[(small-application)
|
|
(let ([c (add1 (- ch cpt-start))])
|
|
(make-application (read-compact cp)
|
|
(for/list ([i (in-range (sub1 c))])
|
|
(read-compact cp))))]
|
|
[(application)
|
|
(let ([c (read-compact-number cp)])
|
|
(make-application (read-compact cp)
|
|
(for/list ([i (in-range c)])
|
|
(read-compact cp))))]
|
|
[(closure)
|
|
(read-compact-number cp) ; symbol table pos. our marshaler will generate this
|
|
(let ([v (read-compact cp)])
|
|
(make-closure
|
|
v
|
|
(gensym
|
|
(let ([s (lam-name v)])
|
|
(cond
|
|
[(symbol? s) s]
|
|
[(vector? s) (vector-ref s 0)]
|
|
[else 'closure])))))]
|
|
[(svector)
|
|
(read-compact-svector cp (read-compact-number cp))]
|
|
[(small-svector)
|
|
(read-compact-svector cp (- ch cpt-start))]
|
|
[else (error 'read-compact "unknown tag ~a" cpt-tag)]))
|
|
(cond
|
|
[(zero? need-car) v]
|
|
[(and proper (= need-car 1))
|
|
(cons v null)]
|
|
[else
|
|
(cons v (loop (sub1 need-car) proper))]))))
|
|
|
|
(define (unmarshal-stx-get/decode cp pos decode-stx)
|
|
(define v2 (read-sym cp pos))
|
|
(define decoded? (vector-ref (cport-decoded cp) pos))
|
|
(if decoded?
|
|
v2
|
|
(let ([dv2 (decode-stx cp v2)])
|
|
(symtab-write! cp pos dv2)
|
|
(vector-set! (cport-decoded cp) pos #t)
|
|
dv2)))
|
|
|
|
(define (symtab-write! cp i v)
|
|
(placeholder-set! (vector-ref (cport-symtab cp) i) v))
|
|
|
|
(define (symtab-lookup cp i)
|
|
(vector-ref (cport-symtab cp) i))
|
|
|
|
(require unstable/markparam)
|
|
(define read-sym-mark (mark-parameter))
|
|
(define (read-sym cp i)
|
|
(define ph (symtab-lookup cp i))
|
|
; We are reading this already, so return the placeholder
|
|
(if (memq i (mark-parameter-all read-sym-mark))
|
|
ph
|
|
; Otherwise, try to read it and return the real thing
|
|
(local [(define vv (placeholder-get ph))]
|
|
(when (not-ready? vv)
|
|
(local [(define save-pos (cport-pos cp))]
|
|
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i)))
|
|
(mark-parameterize
|
|
([read-sym-mark i])
|
|
(let ([v (read-compact cp)])
|
|
(placeholder-set! ph v)))
|
|
(set-cport-pos! cp save-pos)))
|
|
(placeholder-get ph))))
|
|
|
|
;; path -> bytes
|
|
;; implementes read.c:read_compiled
|
|
(define (zo-parse [port (current-input-port)])
|
|
(begin-with-definitions
|
|
;; skip the "#~"
|
|
(unless (equal? #"#~" (read-bytes 2 port))
|
|
(error 'zo-parse "not a bytecode stream"))
|
|
|
|
(define version (read-bytes (min 63 (read-byte port)) port))
|
|
|
|
;; Skip module hash code
|
|
(read-bytes 20 port)
|
|
|
|
(define symtabsize (read-simple-number port))
|
|
|
|
(define all-short (read-byte port))
|
|
|
|
(define cnt (* (if (not (zero? all-short)) 2 4)
|
|
(sub1 symtabsize)))
|
|
|
|
(define so (read-bytes cnt port))
|
|
|
|
(define so* (list->vector (split-so all-short so)))
|
|
|
|
(define shared-size (read-simple-number port))
|
|
(define size* (read-simple-number port))
|
|
|
|
(when (shared-size . >= . size*)
|
|
(error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)"))
|
|
|
|
(define rst-start (file-position port))
|
|
|
|
(file-position port (+ rst-start size*))
|
|
|
|
(unless (eof-object? (read-byte port))
|
|
(error 'zo-parse "File too big"))
|
|
|
|
(define nr (make-not-ready))
|
|
(define symtab
|
|
(build-vector symtabsize (λ (i) (make-placeholder nr))))
|
|
|
|
(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)])
|
|
(read-sym cp i))
|
|
|
|
#;(printf "Parsed table:\n")
|
|
#;(for ([(i v) (in-dict (cport-symtab cp))])
|
|
(printf "~a = ~a\n" i (placeholder-get v)) )
|
|
(set-cport-pos! cp shared-size)
|
|
(make-reader-graph
|
|
(read-marshalled 'compilation-top-type cp))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
#;
|
|
(begin
|
|
(define (compile/write sexp)
|
|
(define s (open-output-bytes))
|
|
(write (parameterize ([current-namespace (make-base-namespace)])
|
|
(eval '(require (for-syntax scheme/base)))
|
|
(compile sexp))
|
|
s)
|
|
(get-output-bytes s))
|
|
|
|
(define (compile/parse sexp)
|
|
(let* ([bs (compile/write sexp)]
|
|
[p (open-input-bytes bs)])
|
|
(zo-parse p)))
|
|
|
|
#;(compile/parse #s(foo 10 13))
|
|
(zo-parse (open-input-file "/home/mflatt/proj/plt/collects/scheme/private/compiled/more-scheme_ss.zo"))
|
|
)
|