37a985a681
The expander as a linklet will be instantiated once, so there's no need to capture references in closures among functions within the expander. Add a "static" linklet compilation mode to inline the variable addresses that would otherwise be referenced via a closure. Although the change is intended to speed up the expander by avoiding some indrections, it also reduces the bytecode size of the expander. Bitmaps that track which linklet variables are used in closures turn out to have been about 25% of the expander's bytecode size, since the linklet has so many definitions.
863 lines
32 KiB
Racket
863 lines
32 KiB
Racket
#lang racket/base
|
|
(require racket/function
|
|
racket/match
|
|
racket/list
|
|
racket/struct
|
|
compiler/zo-structs
|
|
racket/dict
|
|
racket/set)
|
|
|
|
(provide zo-parse)
|
|
(provide (all-from-out compiler/zo-structs))
|
|
|
|
;; ----------------------------------------
|
|
;; Bytecode unmarshalers for various forms
|
|
|
|
(define (read-toplevel flags pos depth)
|
|
(define SCHEME_TOPLEVEL_CONST #x02)
|
|
(define SCHEME_TOPLEVEL_READY #x01)
|
|
;; In the VM, the two flag bits are actually interpreted
|
|
;; as a number when the toplevel is a reference, but we
|
|
;; interpret the bits as flags here for backward compatibility.
|
|
(make-toplevel depth pos
|
|
(positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST))
|
|
(positive? (bitwise-and flags SCHEME_TOPLEVEL_READY))))
|
|
|
|
(define (read-unclosed-procedure flags maybe-closure-size num-params max-let-depth
|
|
name body closed-over tl-map)
|
|
(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)
|
|
(define BITS_PER_ARG 4)
|
|
(let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))])
|
|
(let*-values ([(closure-size)
|
|
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
|
|
(vector-length closed-over)
|
|
maybe-closure-size)]
|
|
[(get-flags) (lambda (i)
|
|
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
|
|
0
|
|
(let ([byte (vector-ref closed-over
|
|
(+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))])
|
|
(bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT)))
|
|
(sub1 (arithmetic-shift 1 BITS_PER_ARG))))))]
|
|
[(num->type) (lambda (n)
|
|
(case n
|
|
[(2) 'flonum]
|
|
[(3) 'fixnum]
|
|
[(4) 'extflonum]
|
|
[else (error "invaid type flag")]))]
|
|
[(arg-types) (let ([num-params ((if rest? sub1 values) num-params)])
|
|
(for/list ([i (in-range num-params)])
|
|
(define v (get-flags i))
|
|
(case v
|
|
[(0) 'val]
|
|
[(1) 'ref]
|
|
[else (num->type v)])))]
|
|
[(closure-types) (for/list ([i (in-range closure-size)]
|
|
[j (in-naturals num-params)])
|
|
(define v (get-flags j))
|
|
(case v
|
|
[(0) 'val/ref]
|
|
[(1) (error "invalid 'ref closure variable")]
|
|
[else (num->type v)]))])
|
|
(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-vector tl-map)]
|
|
[s (in-naturals)])
|
|
(bitwise-ior i (arithmetic-shift v (* s 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-define-values v)
|
|
(make-def-values
|
|
(cdr (vector->list v))
|
|
(vector-ref v 0)))
|
|
|
|
(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-linklet v)
|
|
(match v
|
|
[`(,name ,need-instance-access? ,max-let-depth ,num-lifts ,num-exports
|
|
,body
|
|
,source-names ,defns-vec ,imports-vec ,shapes-vec)
|
|
(define defns (vector->list defns-vec))
|
|
(linkl name
|
|
(map vector->list (vector->list imports-vec))
|
|
(if (not shapes-vec)
|
|
(for/list ([imports (in-vector imports-vec)])
|
|
(for/list ([i (in-vector imports)])
|
|
#f))
|
|
(let ([pos 0])
|
|
(for/list ([imports (in-vector imports-vec)])
|
|
(for/list ([i (in-vector imports)])
|
|
(begin0
|
|
(parse-shape (vector-ref shapes-vec pos))
|
|
(set! pos (add1 pos)))))))
|
|
(take defns num-exports)
|
|
(take (list-tail defns num-exports) (- (length defns) num-exports num-lifts))
|
|
(drop defns (- (length defns) num-lifts))
|
|
(for/hasheq ([i (in-range 0 (vector-length source-names) 2)])
|
|
(values (vector-ref source-names i)
|
|
(vector-ref source-names (add1 i))))
|
|
(vector->list body)
|
|
max-let-depth
|
|
need-instance-access?)]))
|
|
|
|
(define (parse-shape shape)
|
|
(cond
|
|
[(not shape) #f]
|
|
[(eq? shape #t) 'constant]
|
|
[(eq? shape (void)) 'fixed]
|
|
[(number? shape)
|
|
(define n (arithmetic-shift shape -1))
|
|
(make-function-shape (if (negative? n)
|
|
(make-arity-at-least (sub1 (- n)))
|
|
n)
|
|
(odd? shape))]
|
|
[(and (symbol? shape)
|
|
(regexp-match? #rx"^struct" (symbol->string shape)))
|
|
(define n (string->number (substring (symbol->string shape) 6)))
|
|
(define (authentic-shape? n) (bitwise-bit-set? n 4))
|
|
(define (shape-count-shift n) (arithmetic-shift n -5))
|
|
(case (bitwise-and n #x7)
|
|
[(0) (make-struct-type-shape (shape-count-shift n) (authentic-shape? n))]
|
|
[(1) (make-constructor-shape (shape-count-shift n))]
|
|
[(2) (make-predicate-shape (authentic-shape? n))]
|
|
[(3) (make-accessor-shape (shape-count-shift n) (authentic-shape? n))]
|
|
[(4) (make-mutator-shape (shape-count-shift n) (authentic-shape? n))]
|
|
[else (make-struct-other-shape)])]
|
|
[(and (symbol? shape)
|
|
(regexp-match? #rx"^prop" (symbol->string shape)))
|
|
(define n (string->number (substring (symbol->string shape) 4)))
|
|
(case n
|
|
[(0 1) (make-struct-type-property-shape (= n 1))]
|
|
[(2) (make-property-predicate-shape)]
|
|
[else (make-property-accessor-shape)])]
|
|
[else
|
|
;; parse symbol as ":"-separated sequence of arities
|
|
(make-function-shape
|
|
(for/list ([s (regexp-split #rx":" (symbol->string shape))])
|
|
(define i (string->number s))
|
|
(if (negative? i)
|
|
(make-arity-at-least (sub1 (- i)))
|
|
i))
|
|
#f)]))
|
|
|
|
;; ----------------------------------------
|
|
;; Unmarshal dispatch for various types
|
|
|
|
;; Type mappings from "stypes.h":
|
|
(define (int->type i)
|
|
(case i
|
|
[(0) 'toplevel-type]
|
|
[(1) 'static-toplevel-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) 'define-values-type]
|
|
[(16) 'set-bang-type]
|
|
[(17) 'boxenv-type]
|
|
[(18) 'begin0-sequence-type]
|
|
[(19) 'varref-form-type]
|
|
[(20) 'apply-values-type]
|
|
[(21) 'with-immed-mark-type]
|
|
[(22) 'case-lambda-sequence-type]
|
|
[(23) 'inline-variant-type]
|
|
[(25) 'linklet-type]
|
|
[(89) 'prefix-type]
|
|
[else (error 'int->type "unknown type: ~e" i)]))
|
|
|
|
;; ----------------------------------------
|
|
;; 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))
|
|
(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)
|
|
(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 50)
|
|
(define raw-cpt-table
|
|
;; The "schcpt.h" mapping, earlier entries override later ones
|
|
`([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 let-one-typed]
|
|
[19 linklet]
|
|
[20 quote]
|
|
[21 reference]
|
|
[22 local]
|
|
[23 local-unbox]
|
|
[24 svector]
|
|
[25 application]
|
|
[26 let-one]
|
|
[27 branch]
|
|
[28 path]
|
|
[29 closure]
|
|
[30 delayed]
|
|
[31 prefab]
|
|
[32 let-one-unused]
|
|
[33 shared]
|
|
[34 toplevel]
|
|
[35 begin]
|
|
[36 begin0]
|
|
[37 let-value]
|
|
[38 let-void]
|
|
[39 letrec]
|
|
[40 wcm]
|
|
[41 define-values]
|
|
[42 set-bang]
|
|
[43 varref]
|
|
[44 apply-values]
|
|
[45 other-form]
|
|
[46 74 small-number]
|
|
[74 92 small-symbol]
|
|
[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]))
|
|
|
|
;; To accelerate cpt-table lookup, we flatten out the above
|
|
;; list into a vector:
|
|
(define cpt-table (make-vector 256 #f))
|
|
(for ([ent (in-list (reverse raw-cpt-table))])
|
|
;; reverse order so that early entries override later ones.
|
|
(match ent
|
|
[(list k sym) (vector-set! cpt-table k (cons k sym))]
|
|
[(list k k* sym) (for ([i (in-range k k*)])
|
|
(vector-set! cpt-table i (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 SCHEME_LOCAL_TYPE_FLONUM 1)
|
|
(define SCHEME_LOCAL_TYPE_FIXNUM 2)
|
|
(define SCHEME_LOCAL_TYPE_EXTFLONUM 3)
|
|
|
|
(define (make-local unbox? pos flags)
|
|
(define SCHEME_LOCAL_CLEAR_ON_READ 1)
|
|
(define SCHEME_LOCAL_OTHER_CLEARS 2)
|
|
(define SCHEME_LOCAL_TYPE_OFFSET 2)
|
|
(make-localref unbox? pos
|
|
(= flags SCHEME_LOCAL_CLEAR_ON_READ)
|
|
(= flags SCHEME_LOCAL_OTHER_CLEARS)
|
|
(let ([t (- flags SCHEME_LOCAL_TYPE_OFFSET)])
|
|
(cond
|
|
[(= t SCHEME_LOCAL_TYPE_FLONUM) 'flonum]
|
|
[(= t SCHEME_LOCAL_TYPE_EXTFLONUM) 'extflonum]
|
|
[(= t SCHEME_LOCAL_TYPE_FIXNUM) 'fixnum]
|
|
[else #f]))))
|
|
|
|
(define (a . << . b)
|
|
(arithmetic-shift a b))
|
|
|
|
(define-struct not-ready ())
|
|
(define-struct in-progress ())
|
|
|
|
;; ----------------------------------------
|
|
;; Main parsing loop
|
|
|
|
(define (read-compact cp)
|
|
(let loop ([need-car 0] [proper #f])
|
|
(define ch (cp-getc cp))
|
|
(define-values (cpt-start cpt-tag)
|
|
(let ([x (vector-ref cpt-table 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-symref cp pos #t 'delayed))]
|
|
[(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-typed let-one-unused)
|
|
(make-let-one (read-compact cp) (read-compact cp)
|
|
(and (eq? cpt-tag 'let-one-typed)
|
|
(case (read-compact-number cp)
|
|
[(1) 'flonum]
|
|
[(2) 'fixnum]
|
|
[(3) 'extflonum]
|
|
[else #f]))
|
|
(eq? cpt-tag 'let-one-unused))]
|
|
[(branch)
|
|
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
|
|
[(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 ([len (read-compact-number cp)])
|
|
(if (zero? len)
|
|
;; Read a list of byte strings as relative path elements:
|
|
(let ([p (or (current-load-relative-directory)
|
|
(current-directory))])
|
|
(for/fold ([p p]) ([e (in-list (read-compact cp))])
|
|
(build-path p (if (bytes? e) (bytes->path-element e) e))))
|
|
;; Read a path:
|
|
(bytes->path (read-compact-bytes cp len))))]
|
|
[(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)))))]
|
|
[(linklet)
|
|
(unless (zero? (read-compact-number cp))
|
|
;; read and ignore the static-prefix placeholder
|
|
(read-compact cp))
|
|
(read-linklet (read-compact cp))]
|
|
[(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-symref cp l #t 'symref))]
|
|
[(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-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)
|
|
(define pos (read-compact-number cp))
|
|
(define ph (make-placeholder 'closure))
|
|
(symtab-write! cp pos ph)
|
|
(define v (read-compact cp))
|
|
(define r
|
|
(make-closure
|
|
v
|
|
(gensym
|
|
(let ([s (lam-name v)])
|
|
(cond
|
|
[(symbol? s) s]
|
|
[(vector? s) (vector-ref s 0)]
|
|
[else 'closure])))))
|
|
(placeholder-set! ph r)
|
|
r]
|
|
[(svector)
|
|
(read-compact-svector cp (read-compact-number cp))]
|
|
[(small-svector)
|
|
(read-compact-svector cp (- ch cpt-start))]
|
|
[(shared)
|
|
(let ([pos (read-compact-number cp)])
|
|
(read-cyclic cp pos 'shared))]
|
|
[(toplevel)
|
|
(read-toplevel (read-compact-number cp) (read-compact-number cp) (read-compact-number cp))]
|
|
[(begin begin0)
|
|
(define len (read-compact-number cp))
|
|
(define l (for/list ([i (in-range len)]) (read-compact cp)))
|
|
(if (eq? cpt-tag 'begin)
|
|
(make-seq l)
|
|
(make-beg0 l))]
|
|
[(let-value)
|
|
(define count (read-compact-number cp))
|
|
(define pos (read-compact-number cp))
|
|
(define boxes? (not (zero? (read-compact-number cp))))
|
|
(define rhs (read-compact cp))
|
|
(define body (read-compact cp))
|
|
(make-install-value count pos boxes? rhs body)]
|
|
[(let-void)
|
|
(define count (read-compact-number cp))
|
|
(define boxes? (not (zero? (read-compact-number cp))))
|
|
(define body (read-compact cp))
|
|
(make-let-void count boxes? body)]
|
|
[(letrec)
|
|
(define len (read-compact-number cp))
|
|
(define procs (for/list ([i (in-range len)]) (read-compact cp)))
|
|
(define body (read-compact cp))
|
|
(make-let-rec procs body)]
|
|
[(wcm)
|
|
(make-with-cont-mark (read-compact cp) (read-compact cp) (read-compact cp))]
|
|
[(define-values)
|
|
(define v (read-compact cp))
|
|
(make-def-values
|
|
(cdr (vector->list v))
|
|
(vector-ref v 0))]
|
|
[(set-bang)
|
|
(define undef-ok? (not (zero? (read-compact-number cp))))
|
|
(make-assign (read-compact cp) (read-compact cp) undef-ok?)]
|
|
[(varref)
|
|
(define flags (read-compact-number cp))
|
|
(make-varref (read-compact cp) (read-compact cp)
|
|
(bitwise-bit-set? flags 1)
|
|
(bitwise-bit-set? flags 2))]
|
|
[(apply-values)
|
|
(make-apply-values (read-compact cp) (read-compact cp))]
|
|
[(other-form)
|
|
(define type (read-compact-number cp))
|
|
(case (int->type type)
|
|
[(static-toplevel-type)
|
|
(begin0
|
|
(read-toplevel (read-compact-number cp) (read-compact-number cp) 0)
|
|
;; read and discard the prefix identity:
|
|
(read-compact cp))]
|
|
[(prefix-type)
|
|
(read-compact-number cp)]
|
|
[(boxenv-type)
|
|
(make-boxenv (read-compact cp) (read-compact cp))]
|
|
[(with-immed-mark-type)
|
|
(make-with-immed-mark (read-compact cp) (read-compact cp) (read-compact cp))]
|
|
[(inline-variant-type)
|
|
(make-inline-variant (read-compact cp) (read-compact cp))]
|
|
[(case-lambda-sequence-type)
|
|
(define count (read-compact-number cp))
|
|
(define name (read-compact cp))
|
|
(define l (for/list ([i (in-range count)]) (read-compact cp)))
|
|
(make-case-lam name l)]
|
|
[(unclosed-procedure-type)
|
|
(define flags (read-compact-number cp))
|
|
(define CLOS_HAS_TYPED_ARGS 2)
|
|
(define maybe-closure-size (if (positive? (bitwise-and flags CLOS_HAS_TYPED_ARGS))
|
|
(read-compact-number cp)
|
|
-1))
|
|
(define num-params (read-compact-number cp))
|
|
(define max-let-depth (read-compact-number cp))
|
|
(define name (read-compact cp))
|
|
(define body (read-compact cp))
|
|
(define closure-map (read-compact cp))
|
|
(define tl-map (read-compact cp))
|
|
(read-unclosed-procedure flags maybe-closure-size num-params max-let-depth
|
|
name body closure-map tl-map)]
|
|
[else
|
|
(error 'read-compact "unknown other-form type ~a" type)])]
|
|
[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 (symtab-write! cp i v)
|
|
(vector-set! (cport-symtab cp) i v))
|
|
|
|
(define (symtab-lookup cp i)
|
|
(vector-ref (cport-symtab cp) i))
|
|
|
|
(define (read-cyclic cp i who [wrap values])
|
|
(define ph (make-placeholder (not-ready)))
|
|
(symtab-write! cp i ph)
|
|
(define r (wrap (read-compact cp)))
|
|
(when (eq? r ph) (error who "unresolvable cyclic data"))
|
|
(placeholder-set! ph r)
|
|
ph)
|
|
|
|
(define (read-symref cp i mark-in-progress? who)
|
|
(define v (symtab-lookup cp i))
|
|
(cond
|
|
[(not-ready? v)
|
|
(when mark-in-progress?
|
|
(symtab-write! cp i (in-progress)))
|
|
(define save-pos (cport-pos cp))
|
|
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i)))
|
|
(define v (read-compact cp))
|
|
(symtab-write! cp i v)
|
|
(set-cport-pos! cp save-pos)
|
|
v]
|
|
[(in-progress? v)
|
|
(error who "unexpected cycle in input")]
|
|
[else v]))
|
|
|
|
(define (read-prefix port can-be-false?)
|
|
;; skip the "#~"
|
|
(define tag (read-bytes 2 port))
|
|
(unless (or (equal? #"#~" tag)
|
|
(and can-be-false? (equal? #"#f" tag)))
|
|
(error 'zo-parse "not a bytecode stream"))
|
|
|
|
(cond
|
|
[(equal? #"#f" tag) #f]
|
|
[else
|
|
(define version (read-bytes (min 63 (read-byte port)) port))
|
|
(read-char port)]))
|
|
|
|
;; path -> bytes
|
|
;; implementes read.c:read_compiled
|
|
(define (zo-parse [port (current-input-port)])
|
|
(define init-pos (file-position port))
|
|
|
|
(define mode (read-prefix port #f))
|
|
|
|
(case mode
|
|
[(#\B) (linkl-bundle (zo-parse-top port))]
|
|
[(#\D)
|
|
(struct sub-info (name start len))
|
|
(define sub-infos
|
|
(sort
|
|
(for/list ([i (in-range (read-simple-number port))])
|
|
(define size (read-simple-number port))
|
|
(define name (read-bytes size port))
|
|
(define start (read-simple-number port))
|
|
(define len (read-simple-number port))
|
|
(define left (read-simple-number port))
|
|
(define right (read-simple-number port))
|
|
(define name-p (open-input-bytes name))
|
|
(sub-info (let loop ()
|
|
(define c (read-byte name-p))
|
|
(if (eof-object? c)
|
|
null
|
|
(cons (string->symbol
|
|
(bytes->string/utf-8 (read-bytes (if (= c 255)
|
|
(read-simple-number port)
|
|
c)
|
|
name-p)))
|
|
(loop))))
|
|
start
|
|
len))
|
|
<
|
|
#:key sub-info-start))
|
|
(define (remove-empty-root ht)
|
|
;; A linklet for top-level forms will have '() mapped to #f
|
|
(if (hash-ref ht '() #f)
|
|
ht
|
|
(hash-remove ht '())))
|
|
(linkl-directory
|
|
(remove-empty-root
|
|
(for/hash ([sub-info (in-list sub-infos)])
|
|
(define pos (file-position port))
|
|
(unless (= (- pos init-pos) (sub-info-start sub-info))
|
|
(error 'zo-parse
|
|
"next bundle expected at ~a, currently at ~a"
|
|
(+ init-pos (sub-info-start sub-info)) pos))
|
|
(define tag (read-prefix port #t))
|
|
(define sub
|
|
(cond
|
|
[(not tag) #f]
|
|
[else
|
|
(unless (eq? tag #\B)
|
|
(error 'zo-parse "expected a bundle"))
|
|
(define sub (and tag (zo-parse-top port #f)))
|
|
(unless (hash? sub)
|
|
(error 'zo-parse "expected a bundle hash"))
|
|
(linkl-bundle sub)]))
|
|
(values (sub-info-name sub-info) sub))))]
|
|
[else
|
|
(error 'zo-parse "bad file format specifier")]))
|
|
|
|
(define (zo-parse-top [port (current-input-port)] [check-end? #t])
|
|
|
|
;; 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*))
|
|
|
|
(when check-end?
|
|
(unless (eof-object? (read-byte port))
|
|
(error 'zo-parse "File too big")))
|
|
|
|
(define symtab (make-vector symtabsize (not-ready)))
|
|
|
|
(define cp
|
|
(make-cport 0 shared-size port size* rst-start symtab so*))
|
|
|
|
(for ([i (in-range 1 symtabsize)])
|
|
(read-symref cp i #f 'table))
|
|
|
|
#;(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-compact 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"))
|
|
)
|