1024 lines
43 KiB
Scheme
1024 lines
43 KiB
Scheme
#lang scheme/base
|
|
(require mzlib/etc
|
|
scheme/match
|
|
scheme/list)
|
|
|
|
(provide zo-parse)
|
|
|
|
;; ----------------------------------------
|
|
;; Structures to represent bytecode
|
|
|
|
(define-syntax-rule (define-form-struct* id id+par (field-id ...))
|
|
(begin
|
|
(define-struct id+par (field-id ...) #:transparent)
|
|
(provide (struct-out id))))
|
|
|
|
(define-syntax define-form-struct
|
|
(syntax-rules ()
|
|
[(_ (id sup) . rest)
|
|
(define-form-struct* id (id sup) . rest)]
|
|
[(_ id . rest)
|
|
(define-form-struct* id id . rest)]))
|
|
|
|
(define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this
|
|
|
|
(define-form-struct prefix (num-lifts toplevels stxs)) ; sets up top-level and syntax-object array
|
|
|
|
;; In toplevels of resove prefix:
|
|
(define-form-struct global-bucket (name)) ; top-level binding
|
|
(define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id
|
|
|
|
;; In stxs of prefix:
|
|
(define-form-struct stx (encoded))
|
|
|
|
(define-form-struct form ())
|
|
(define-form-struct (expr form) ())
|
|
|
|
(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported
|
|
max-let-depth dummy lang-info internal-context))
|
|
|
|
(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map max-let-depth body)) ; `lambda'
|
|
(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over)
|
|
(define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam
|
|
|
|
(define-form-struct (let-one expr) (rhs body)) ; pushes one value onto stack
|
|
(define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots
|
|
(define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s)
|
|
(define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots
|
|
(define-form-struct (boxenv expr) (pos body)) ; box existing stack element
|
|
|
|
(define-form-struct (localref expr) (unbox? pos clear? other-clears?)) ; access local via stack
|
|
|
|
(define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack)
|
|
(define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
|
|
|
|
(define-form-struct (application expr) (rator rands)) ; function call
|
|
(define-form-struct (branch expr) (test then else)) ; `if'
|
|
(define-form-struct (with-cont-mark expr) (key val body)) ; `with-continuation-mark'
|
|
(define-form-struct (beg0 expr) (seq)) ; `begin0'
|
|
(define-form-struct (seq form) (forms)) ; `begin'
|
|
(define-form-struct (splice form) (forms)) ; top-level `begin'
|
|
(define-form-struct (varref expr) (toplevel)) ; `#%variable-reference'
|
|
(define-form-struct (assign expr) (id rhs undef-ok?)) ; top-level or module-level set!
|
|
(define-form-struct (apply-values expr) (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc)
|
|
(define-form-struct (primval expr) (id)) ; direct preference to a kernel primitive
|
|
|
|
;; Definitions (top level or within module):
|
|
(define-form-struct (def-values form) (ids rhs))
|
|
(define-form-struct (def-syntaxes form) (ids rhs prefix max-let-depth))
|
|
(define-form-struct (def-for-syntax form) (ids rhs prefix max-let-depth))
|
|
|
|
;; Top-level `require'
|
|
(define-form-struct (req form) (reqs dummy))
|
|
|
|
;; A static closure can refer directly to itself, creating a cycle
|
|
(define-struct indirect ([v #:mutable]) #:prefab)
|
|
(provide (struct-out indirect))
|
|
|
|
;; A provided identifier
|
|
(define-form-struct provided (name src src-name nom-src src-phase protected? insp))
|
|
|
|
;; ----------------------------------------
|
|
;; 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)
|
|
(make-prefix i (vector->list tv) (vector->list sv))])))
|
|
|
|
(define (read-unclosed-procedure v)
|
|
(define CLOS_HAS_REST 1)
|
|
(define CLOS_HAS_REF_ARGS 2)
|
|
(define CLOS_PRESERVES_MARKS 4)
|
|
(define CLOS_IS_METHOD 16)
|
|
(define CLOS_SINGLE_RESULT 32)
|
|
(define BITS_PER_MZSHORT 32)
|
|
(match v
|
|
[`(,flags ,num-params ,max-let-depth ,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)))]
|
|
[(arg-types) (let ([num-params ((if rest? sub1 values) num-params)])
|
|
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
|
|
(for/list ([i (in-range num-params)]) 'val)
|
|
(for/list ([i (in-range num-params)])
|
|
(if (bitwise-bit-set?
|
|
(vector-ref closed-over
|
|
(+ closure-size (quotient i BITS_PER_MZSHORT)))
|
|
(remainder i BITS_PER_MZSHORT))
|
|
'ref
|
|
'val))))])
|
|
(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 rest? sub1 values) 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))
|
|
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))
|
|
|
|
(define (read-define-values v)
|
|
(make-def-values
|
|
(cdr (vector->list v))
|
|
(vector-ref v 0)))
|
|
|
|
(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 (read-module v)
|
|
(match v
|
|
[`(,name ,self-modidx ,lang-info ,functional? ,et-functional?
|
|
,rename ,max-let-depth ,dummy
|
|
,prefix
|
|
,indirect-provides ,num-indirect-provides
|
|
,indirect-syntax-provides ,num-indirect-syntax-provides
|
|
,indirect-et-provides ,num-indirect-et-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 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)
|
|
more-requires)
|
|
(vector->list body)
|
|
(map (lambda (sb)
|
|
(match sb
|
|
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
|
|
((if for-stx?
|
|
make-def-for-syntax
|
|
make-def-syntaxes)
|
|
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]
|
|
[(96) 'case-lambda-sequence-type]
|
|
[(97) 'begin0-sequence-type]
|
|
[(100) 'module-type]
|
|
[(102) 'resolve-prefix-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))))
|
|
|
|
(define (get-reader type)
|
|
(or (hash-ref type-readers type #f)
|
|
(lambda (v)
|
|
(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)
|
|
(loop (subbytes so n))))))
|
|
|
|
(define (read-simple-number p)
|
|
;; not sure if it's really unsigned
|
|
(integer-bytes->integer (read-bytes 4 p) #f #f))
|
|
|
|
(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns mpis))
|
|
|
|
(define (cp-getc cp)
|
|
(begin-with-definitions
|
|
(when ((cport-pos cp) . >= . (cport-size cp))
|
|
(error "off the end"))
|
|
(define r
|
|
(bytes-ref (cport-bytes 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 gstx] ; unused
|
|
[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 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
|
|
(subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos 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)
|
|
(list->vector (reverse (for/list ([i (in-range n)]) (read-compact-number port)))))
|
|
|
|
(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)
|
|
(make-localref unbox? pos
|
|
(positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ))
|
|
(positive? (bitwise-and flags SCHEME_LOCAL_OTHER_CLEARS))))
|
|
|
|
(define (a . << . b)
|
|
(arithmetic-shift a b))
|
|
|
|
(define-struct not-ready ())
|
|
|
|
;; ----------------------------------------
|
|
;; Synatx unmarshaling
|
|
|
|
(define-form-struct wrapped (datum wraps certs))
|
|
|
|
(define-form-struct wrap ())
|
|
(define-form-struct (lexical-rename wrap) (alist))
|
|
(define-form-struct (phase-shift wrap) (amt src dest))
|
|
(define-form-struct (prune wrap) (sym))
|
|
(define-form-struct (module-rename wrap) (phase kind set-id unmarshals renames mark-renames plus-kern?))
|
|
|
|
(define-form-struct all-from-module (path phase src-phase exceptions prefix))
|
|
(define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id))
|
|
|
|
(define (decode-stx cp v)
|
|
(if (integer? v)
|
|
(let-values ([(v2 decoded?) (unmarshal-stx-get cp v)])
|
|
(if decoded?
|
|
v2
|
|
(let ([v2 (decode-stx cp v2)])
|
|
(unmarshal-stx-set! cp v v2)
|
|
v2)))
|
|
(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: ~e" v)])])
|
|
(let* ([wraps (decode-wraps cp encoded-wraps)]
|
|
[add-wrap (lambda (v) (make-wrapped v wraps cert-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 (cdr (vector->list (struct->vector 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 (cdr (vector->list (struct->vector v)))))))]
|
|
[else (add-wrap v)]))))))
|
|
|
|
(define (decode-wraps cp w)
|
|
(if (integer? w)
|
|
(let-values ([(w2 decoded?) (unmarshal-stx-get cp w)])
|
|
(if decoded?
|
|
w2
|
|
(let ([w2 (decode-wraps cp w2)])
|
|
(unmarshal-stx-set! cp w w2)
|
|
w2)))
|
|
(map (lambda (a)
|
|
(let aloop ([a a])
|
|
(cond
|
|
[(integer? a)
|
|
(let-values ([(a2 decoded?) (unmarshal-stx-get cp a)])
|
|
(if decoded?
|
|
a2
|
|
(let ([a2 (aloop a2)])
|
|
(unmarshal-stx-set! cp a a2)
|
|
a2)))]
|
|
[(and (pair? a) (null? (cdr a)) (number? (car a)))
|
|
;; a mark
|
|
(string->symbol (format "mark~a" (car a)))]
|
|
[(vector? a)
|
|
(make-lexical-rename
|
|
(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 (lambda (u)
|
|
(let ([just-phase? (let ([v (cddr u)])
|
|
(or (number? v) (not v)))])
|
|
(let-values ([(exns prefix)
|
|
(if just-phase?
|
|
(values null #f)
|
|
(let loop ([u (if just-phase? null (cdddr u))]
|
|
[a null])
|
|
(if (pair? u)
|
|
(loop (cdr u) (cons (car u) a))
|
|
(values (reverse a) u))))])
|
|
(make-all-from-module
|
|
(parse-module-path-index cp (car u))
|
|
(cadr u)
|
|
(if just-phase?
|
|
(cddr u)
|
|
(caddr u))
|
|
exns
|
|
prefix))))
|
|
unmarshals)
|
|
(let loop ([i 0])
|
|
(if (= i (vector-length renames))
|
|
null
|
|
(cons
|
|
(let ([key (vector-ref renames i)]
|
|
[make-mapping
|
|
(lambda (path mod-phase import-phase id nominal-path nominal-phase nominal-id)
|
|
(make-module-binding
|
|
(parse-module-path-index cp path)
|
|
mod-phase
|
|
import-phase
|
|
id
|
|
(parse-module-path-index cp nominal-path)
|
|
nominal-phase
|
|
(if (eq? id nominal-id) #t nominal-id)))])
|
|
(cons key
|
|
(let ([m (vector-ref renames (add1 i))]
|
|
[parse-nominal-modidx-plus-phase
|
|
(lambda (modidx mod-phase exportname nominal-modidx-plus-phase nom-exportname)
|
|
(match nominal-modidx-plus-phase
|
|
[`(,nominal-modidx ,import-phase-plus-nominal-phase)
|
|
(match import-phase-plus-nominal-phase
|
|
[`(,import-phase ,nom-phase)
|
|
(make-mapping modidx mod-phase import-phase exportname
|
|
nominal-modidx nom-phase nom-exportname)]
|
|
[import-phase
|
|
(make-mapping modidx mod-phase import-phase exportname
|
|
modidx mod-phase nom-exportname)])]
|
|
[nominal-modidx
|
|
(make-mapping modidx mod-phase '* exportname
|
|
nominal-modidx mod-phase nom-exportname)]))])
|
|
(match m
|
|
[`(,modidx ,mod-phase ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname)
|
|
(parse-nominal-modidx-plus-phase modidx mod-phase exportname
|
|
nominal-modidx-plus-phase nominal-exportname)]
|
|
[`(,modidx ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname)
|
|
(parse-nominal-modidx-plus-phase modidx '* exportname
|
|
nominal-modidx-plus-phase nominal-exportname)]
|
|
[`(,modidx ,nominal-modidx)
|
|
(make-mapping modidx '* '* key nominal-modidx '* key)]
|
|
[`(,modidx ,exportname)
|
|
(make-mapping modidx '* '* exportname modidx '* exportname)]
|
|
[modidx
|
|
(make-mapping modidx '* '* key modidx '* key)]))))
|
|
(loop (+ i 2)))))
|
|
mark-renames
|
|
(and plus-kern? 'plus-kern)))]
|
|
[else (error "bad module rename: ~e" a)]))]
|
|
[(boolean? a)
|
|
`(#%top-level-rename ,a)]
|
|
[(symbol? a)
|
|
'(#%mark-barrier)]
|
|
[(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)])))
|
|
w)))
|
|
|
|
(define (unmarshal-stx-get cp pos)
|
|
(if (pos . >= . (vector-length (cport-symtab cp)))
|
|
(values `(#%bad-index ,pos) #t)
|
|
(let ([v (vector-ref (cport-symtab cp) pos)])
|
|
(if (not-ready? v)
|
|
(let ([save-pos (cport-pos cp)])
|
|
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
|
|
(let ([v (read-compact cp)])
|
|
(vector-set! (cport-symtab cp) pos v)
|
|
(set-cport-pos! cp save-pos)
|
|
(values v #f)))
|
|
(values v (vector-ref (cport-decoded cp) pos))))))
|
|
|
|
(define (unmarshal-stx-set! cp pos v)
|
|
(vector-set! (cport-symtab cp) pos v)
|
|
(vector-set! (cport-decoded cp) pos #t))
|
|
|
|
(define (parse-module-path-index cp s)
|
|
(cond
|
|
[(not s) #f]
|
|
[(module-path-index? s)
|
|
(hash-ref (cport-mpis cp) s
|
|
(lambda ()
|
|
(let-values ([(name base) (module-path-index-split s)])
|
|
(let ([v `(module-path-index-join
|
|
(quote ,name)
|
|
,(parse-module-path-index cp base))])
|
|
(hash-set! (cport-mpis cp) s v)
|
|
v))))]
|
|
[else `(quote ,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)])
|
|
(let ([v (vector-ref (cport-symtab cp) pos)])
|
|
(if (not-ready? v)
|
|
(let ([save-pos (cport-pos cp)])
|
|
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
|
|
(let ([v (read-compact cp)])
|
|
(vector-set! (cport-symtab cp) pos v)
|
|
(set-cport-pos! cp save-pos)
|
|
v))
|
|
v)))]
|
|
[(escape)
|
|
(let* ([len (read-compact-number cp)]
|
|
[s (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos 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])
|
|
(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)
|
|
(make-let-one (read-compact cp) (read-compact cp))]
|
|
[(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) (let* ([n (read-compact-number cp)]
|
|
[lst (for/list ([i (in-range n)])
|
|
(read-compact cp))])
|
|
(vector->immutable-vector (list->vector lst)))]
|
|
[(list) (let* ([n (read-compact-number cp)])
|
|
(append
|
|
(for/list ([i (in-range n)])
|
|
(read-compact cp))
|
|
(read-compact cp)))]
|
|
[(prefab)
|
|
(let ([v (read-compact cp)])
|
|
(apply make-prefab-struct
|
|
(vector-ref v 0)
|
|
(cdr (vector->list v))))]
|
|
[(hash-table)
|
|
(let ([eq (read-compact-number cp)]
|
|
[len (read-compact-number cp)])
|
|
((if (zero? eq)
|
|
make-hash-placeholder
|
|
make-hasheq-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)]
|
|
[v (vector-ref (cport-symtab cp) l)])
|
|
(if (not-ready? v)
|
|
(let ([pos (cport-pos cp)])
|
|
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l)))
|
|
(let ([v (read-compact cp)])
|
|
(set-cport-pos! cp pos)
|
|
(vector-set! (cport-symtab cp) l v)
|
|
v))
|
|
v))]
|
|
[(weird-symbol)
|
|
(let ([u (read-compact-number cp)]
|
|
[str (read-compact-chars cp (read-compact-number cp))])
|
|
;; FIXME: no way to construct quasi-interned symbols:
|
|
(string->uninterned-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)
|
|
(let* ([l (read-compact-number cp)]
|
|
[ind (make-indirect #f)])
|
|
(vector-set! (cport-symtab cp) l ind)
|
|
(let* ([v (read-compact cp)]
|
|
[cl (make-closure v (gensym
|
|
(let ([s (lam-name v)])
|
|
(cond
|
|
[(symbol? s) s]
|
|
[(vector? s) (vector-ref s 0)]
|
|
[else 'closure]))))])
|
|
(set-indirect-v! ind cl)
|
|
ind))]
|
|
[(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))]))))
|
|
|
|
;; path -> bytes
|
|
;; implementes read.c:read_compiled
|
|
(define (zo-parse 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))
|
|
|
|
(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 'bad-read))
|
|
|
|
(define rst (read-bytes size* port))
|
|
|
|
(unless (eof-object? (read-byte port))
|
|
(error 'not-end))
|
|
|
|
(unless (= size* (bytes-length rst))
|
|
(error "wrong number of bytes"))
|
|
|
|
(define symtab (make-vector symtabsize (make-not-ready)))
|
|
|
|
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
|
|
|
|
(for/list ([i (in-range 1 symtabsize)])
|
|
(when (not-ready? (vector-ref symtab i))
|
|
(set-cport-pos! cp (vector-ref so* (sub1 i)))
|
|
(let ([v (read-compact cp)])
|
|
(vector-set! symtab i v))))
|
|
|
|
(set-cport-pos! cp shared-size)
|
|
(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"))
|
|
)
|